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