R/filehash.R

   1 ######################################################################
   2 ## Copyright (C) 2006, Roger D. Peng <rpeng@jhsph.edu>
   3 ##
   4 ## This program is free software; you can redistribute it and/or modify
   5 ## it under the terms of the GNU General Public License as published by
   6 ## the Free Software Foundation; either version 2 of the License, or
   7 ## (at your option) any later version.
   8 ##
   9 ## This program is distributed in the hope that it will be useful,
  10 ## but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ## GNU General Public License for more details.
  13 ##
  14 ## You should have received a copy of the GNU General Public License
  15 ## along with this program; if not, write to the Free Software
  16 ## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17 ## 02110-1301, USA
  18 #####################################################################
  19
  20 ######################################################################
  21 ## Class 'filehash'
  22
  23 setClass("filehash", representation(name = "character"))
  24
  25 setValidity("filehash", function(object) {
  26     if(length(object@name) == 0)
  27         "database name has length 0"
  28     else
  29         TRUE
  30 })
  31
  32 setGeneric("dbName", function(db) standardGeneric("dbName"))
  33 setMethod("dbName", "filehash", function(db) db@name)
  34
  35 setMethod("show", "filehash",
  36           function(object) {
  37               if(length(object@name) == 0)
  38                   stop("database does not have a name")
  39               cat(gettextf("'%s' database '%s'\n", as.character(class(object)),
  40                            object@name))
  41           })
  42
  43
  44 ######################################################################
  45
  46 registerFormatDB <- function(name, funlist) {
  47     if(!all(c("initialize", "create") %in% names(funlist)))
  48         stop("need both 'initialize' and 'create' functions in 'funlist'")
  49     r <- list(list(create = funlist[["create"]],
  50                    initialize = funlist[["initialize"]]))
  51     names(r) <- name
  52     do.call("filehashFormats", r)
  53     TRUE
  54 }
  55
  56 filehashFormats <- function(...) {
  57     args <- list(...)
  58     n <- names(args)
  59
  60     for(n in names(args))
  61         assign(n, args[[n]], .filehashFormats)
  62     current <- as.list(.filehashFormats)
  63
  64     if(length(args) == 0)
  65         current
  66     else
  67     invisible(current)
  68 }
  69
  70 ######################################################################
  71 ## Create necessary database files.  On successful creation, return
  72 ## TRUE.  If the database already exists, don't do anything but return
  73 ## TRUE (and print a message).  If there's any other strange
  74 ## condition, return FALSE.
  75
  76 dbStartup <- function(dbName, type, action = c("initialize", "create")) {
  77     action <- match.arg(action)
  78     validFormat <- type %in% names(filehashFormats())
  79
  80     if(!validFormat)
  81         stop(gettextf("'%s' not a valid database format", type))
  82     formatList <- filehashFormats()[[type]]
  83     doFUN <- formatList[[action]]
  84
  85     if(!is.function(doFUN))
  86         stop(gettextf("'%s' function for database format '%s' is not valid",
  87                       action, type))
  88     doFUN(dbName)
  89 }
  90
  91 setGeneric("dbCreate", function(db, ...) standardGeneric("dbCreate"))
  92
  93 setMethod("dbCreate", "ANY",
  94           function(db, type = NULL, ...) {
  95               if(is.null(type))
  96                   type <- filehashOption()$defaultType
  97
  98               dbStartup(db, type, "create")
  99               TRUE
 100           })
 101
 102 setGeneric("dbInit", function(db, ...) standardGeneric("dbInit"))
 103
 104 setMethod("dbInit", "ANY",
 105           function(db, type = NULL, ...) {
 106               if(is.null(type))
 107                   type <- filehashOption()$defaultType
 108               dbStartup(db, type, "initialize")
 109           })
 110
 111 ######################################################################
 112 ## Set options and retrieve list of options
 113
 114 filehashOption <- function(...) {
 115     args <- list(...)
 116     n <- names(args)
 117
 118     for(n in names(args))
 119         assign(n, args[[n]], .filehashOptions)
 120     current <- as.list(.filehashOptions)
 121
 122     if(length(args) == 0)
 123         current
 124     else
 125         invisible(current)
 126 }
 127
 128 ######################################################################
 129 ## Load active bindings into an environment
 130
 131 setGeneric("dbLoad", function(db, ...) standardGeneric("dbLoad"))
 132
 133 setMethod("dbLoad", "filehash",
 134           function(db, env = parent.frame(2), keys = NULL, ...) {
 135               if(is.null(keys))
 136                   keys <- dbList(db)
 137               else if(!is.character(keys))
 138                   stop("'keys' should be a character vector")
 139               active <- sapply(keys, function(k) {
 140                   exists(k, env, inherits = FALSE)
 141               })
 142               if(any(active)) {
 143                   warning("keys with active/regular bindings ignored: ",
 144                           paste(sQuote(keys[active]), collapse = ", "))
 145                   keys <- keys[!active]
 146               }
 147               make.f <- function(k) {
 148                   key <- k
 149                   function(value) {
 150                       if(!missing(value)) {
 151                           dbInsert(db, key, value)
 152                           invisible(value)
 153                       }
 154                       else {
 155                           obj <- dbFetch(db, key)
 156                           obj
 157                       }
 158                   }
 159               }
 160               for(k in keys)
 161                   makeActiveBinding(k, make.f(k), env)
 162               invisible(keys)
 163           })
 164
 165 setGeneric("dbLazyLoad", function(db, ...) standardGeneric("dbLazyLoad"))
 166
 167 setMethod("dbLazyLoad", "filehash",
 168           function(db, env = parent.frame(2), keys = NULL, ...) {
 169               if(is.null(keys))
 170                   keys <- dbList(db)
 171               else if(!is.character(keys))
 172                   stop("'keys' should be a character vector")
 173
 174               wrap <- function(x, env) {
 175                   key <- x
 176                   delayedAssign(x, dbFetch(db, key), environment(), env)
 177               }
 178               for(k in keys)
 179                   wrap(k, env)
 180               invisible(keys)
 181           })
 182
 183 ## Load active bindings into an environment and return the environment
 184
 185 db2env <- function(db) {
 186     if(is.character(db))
 187         db <- dbInit(db)  ## use the default type
 188     env <- new.env(hash = TRUE)
 189     dbLoad(db, env)
 190     env
 191 }
 192
 193 ######################################################################
 194 ## Other methods
 195
 196 setGeneric("with")
 197 setMethod("with", "filehash",
 198           function(data, expr, ...) {
 199               env <- db2env(data)
 200               eval(substitute(expr), env, enclos = parent.frame())
 201           })
 202
 203 setGeneric("lapply")
 204 setMethod("lapply", signature(X = "filehash"),
 205           function(X, FUN, ..., keep.names = TRUE) {
 206               FUN <- match.fun(FUN)
 207               keys <- dbList(X)
 208               rval <- vector("list", length = length(keys))
 209
 210               for(i in seq(along = keys)) {
 211                   obj <- dbFetch(X, keys[i])
 212                   rval[[i]] <- FUN(obj, ...)
 213               }
 214               if(keep.names)
 215                   names(rval) <- keys
 216               rval
 217           })
 218
 219 ######################################################################
 220 ## Database interface
 221
 222 setGeneric("dbMultiFetch", function(db, key, ...) standardGeneric("dbMultiFetch"))
 223 setGeneric("dbInsert", function(db, key, value, ...) standardGeneric("dbInsert"))
 224 setGeneric("dbFetch", function(db, key, ...) standardGeneric("dbFetch"))
 225 setGeneric("dbExists", function(db, key, ...) standardGeneric("dbExists"))
 226 setGeneric("dbList", function(db, ...) standardGeneric("dbList"))
 227 setGeneric("dbDelete", function(db, key, ...) standardGeneric("dbDelete"))
 228 setGeneric("dbReorganize", function(db, ...) standardGeneric("dbReorganize"))
 229 setGeneric("dbUnlink", function(db, ...) standardGeneric("dbUnlink"))
 230
 231 ######################################################################
 232 ## Extractor/replacement
 233
 234 setMethod("[[", signature(x = "filehash", i = "character", j = "missing"),
 235           function(x, i, j) {
 236               dbFetch(x, i)
 237           })
 238
 239 setMethod("$", signature(x = "filehash", name = "character"),
 240           function(x, name) {
 241               dbFetch(x, name)
 242           })
 243
 244 setReplaceMethod("[[", signature(x = "filehash", i = "character", j = "missing"),
 245                  function(x, i, j, value) {
 246                      dbInsert(x, i, value)
 247                      x
 248                  })
 249
 250 setReplaceMethod("$", signature(x = "filehash", name = "character"),
 251                  function(x, name, value) {
 252                      dbInsert(x, name, value)
 253                      x
 254                  })
 255
 256
 257 ## Need to define these because they're not automatically caught.
 258 ## Don't need this if R >= 2.4.0.
 259
 260 setReplaceMethod("[[", signature(x = "filehash", i = "numeric", j = "missing"),
 261                  function(x, i, j, value) {
 262                      stop("numeric indices not allowed")
 263                  })
 264
 265 setMethod("[[", signature(x = "filehash", i = "numeric", j = "missing"),
 266           function(x, i, j) {
 267               stop("numeric indices not allowed")
 268           })
 269
 270 setMethod("[", signature(x = "filehash", i = "ANY", j = "ANY", drop = "missing"),
 271           function(x, i, j, drop) {
 272               stop("multiple indices via '[' not allowed")
 273           })
 274
 275
 276
 277
 278
 279