R/filehash-RDS.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 'filehashRDS'
  22
  23 setClass("filehashRDS",
  24          representation(dir = "character"),
  25          contains = "filehash"
  26          )
  27
  28 setValidity("filehashRDS",
  29             function(object) {
  30                     if(length(object@dir) != 1)
  31                             return("only one directory should be set in 'dir'")
  32                     if(!file.exists(object@dir))
  33                             return(gettextf("directory '%s' does not exist",
  34                                             object@dir))
  35                     TRUE
  36             })
  37
  38 createRDS <- function(dbName) {
  39         dir <- dbName
  40
  41         if(!file.exists(dir))
  42                 dir.create(dir)
  43         else
  44                 message(gettextf("database '%s' already exists", dbName))
  45         TRUE
  46 }
  47
  48 initializeRDS <- function(dbName) {
  49         ## Trailing '/' causes a problem in Windows?
  50         dbName <- sub("/$", "", dbName, perl = TRUE)
  51         new("filehashRDS", dir = normalizePath(dbName),
  52             name = basename(dbName))
  53 }
  54
  55 ## For case-insensitive file systems, objects with the same name but
  56 ## differ by capitalization might get clobbered.  `mangleName()'
  57 ## inserts a "@" before each capital letter and `unMangleName()'
  58 ## reverses the operation.
  59
  60 mangleName <- function(oname) {
  61         gsub("([A-Z])", "@\\1", oname, perl = TRUE)
  62 }
  63
  64 unMangleName <- function(mname) {
  65         gsub("@", "", mname, fixed = TRUE)
  66 }
  67
  68 ## Function for mapping a key to a path on the filesystem
  69 setGeneric("objectFile", function(db, key) standardGeneric("objectFile"))
  70 setMethod("objectFile", signature(db = "filehashRDS", key = "character"),
  71           function(db, key) {
  72                   file.path(db@dir, mangleName(key))
  73           })
  74
  75 ################################################################################
  76 ## Interface functions
  77
  78 setMethod("dbInsert",
  79           signature(db = "filehashRDS", key = "character", value = "ANY"),
  80           function(db, key, value, ...) {
  81                   ## open connection to a gzip compressed file
  82                   con <- gzfile(objectFile(db, key), "wb")
  83
  84                   ## serialize data to connection; return TRUE on success
  85                   tryCatch({
  86                           serialize(value, con)
  87                   }, error = function(err) {
  88                           err
  89                   }, interrupt = function(cond) {
  90                           cond
  91                   }, finally = close(con))
  92           }
  93           )
  94
  95 setMethod("dbFetch", signature(db = "filehashRDS", key = "character"),
  96           function(db, key, ...) {
  97                   ## create filename from key
  98                   ofile <- objectFile(db, key)
  99
 100                   con <- tryCatch({
 101                           gzfile(ofile, "rb")
 102                   }, error = function(cond) {
 103                           cond
 104                   })
 105                   if(inherits(con, "condition"))
 106                           stop(gettextf("error obtaining value for key '%s': %s",
 107                                         key,
 108                                         conditionMessage(con)))
 109                   on.exit(close(con))
 110
 111                   val <- unserialize(con)
 112                   val
 113           })
 114
 115 setMethod("dbExists", signature(db = "filehashRDS", key = "character"),
 116           function(db, key, ...) {
 117                   key %in% dbList(db)
 118           })
 119
 120 setMethod("dbList", "filehashRDS",
 121           function(db, ...) {
 122                   ## list all keys/files in the database
 123                   fileList <- dir(db@dir, all.files = TRUE, full.names = TRUE)
 124                   use <- !file.info(fileList)$isdir
 125                   fileList <- basename(fileList[use])
 126
 127                   unMangleName(fileList)
 128           })
 129
 130 setMethod("dbDelete", signature(db = "filehashRDS", key = "character"),
 131           function(db, key, ...) {
 132                   ofile <- objectFile(db, key)
 133
 134                   ## remove/delete the file
 135                   status <- file.remove(ofile)
 136                   isTRUE(status)
 137           })
 138
 139 setMethod("dbUnlink", "filehashRDS",
 140           function(db, ...) {
 141                   ## delete the entire database directory
 142                   d <- db@dir
 143                   unlink(d, recursive = TRUE)
 144           })
 145