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, safe = TRUE, ...) {
  84                   writefile <- if(safe)
  85                           tempfile()
  86                   else
  87                           objectFile(db, key)
  88                   con <- gzfile(writefile, "wb")
  89
  90                   writestatus <- tryCatch({
  91                           serialize(value, con)
  92                   }, condition = function(cond) {
  93                           cond
  94                   }, finally = {
  95                           close(con)
  96                   })
  97                   if(inherits(writestatus, "condition"))
  98                           stop(gettextf("unable to write object '%s'", key))
  99                   if(!safe)
 100                           return(invisible(!inherits(writestatus, "condition")))
 101
 102                   cpstatus <- file.copy(writefile, objectFile(db, key),
 103                                         overwrite = TRUE)
 104
 105                   if(!cpstatus)
 106                           stop(gettextf("unable to insert object '%s'", key))
 107                   else {
 108                           rmstatus <- file.remove(writefile)
 109
 110                           if(!rmstatus)
 111                                   warning("unable to remove temporary file")
 112                   }
 113                   invisible(cpstatus)
 114           })
 115
 116 setMethod("dbFetch", signature(db = "filehashRDS", key = "character"),
 117           function(db, key, ...) {
 118                   ## Create filename from key
 119                   ofile <- objectFile(db, key)
 120
 121                   ## Open connection
 122                   con <- tryCatch({
 123                           gzfile(ofile, "rb")
 124                   }, condition = function(cond) {
 125                           cond
 126                   })
 127                   if(inherits(con, "condition"))
 128                           stop(gettextf("error obtaining value for key '%s'",
 129                                         key))
 130                   on.exit(close(con))
 131
 132                   ## Read data
 133                   val <- unserialize(con)
 134                   val
 135           })
 136
 137 setMethod("dbExists", signature(db = "filehashRDS", key = "character"),
 138           function(db, key, ...) {
 139                   key %in% dbList(db)
 140           })
 141
 142 setMethod("dbList", "filehashRDS",
 143           function(db, ...) {
 144                   ## list all keys/files in the database
 145                   fileList <- dir(db@dir, all.files = TRUE, full.names = TRUE)
 146                   use <- !file.info(fileList)$isdir
 147                   fileList <- basename(fileList[use])
 148
 149                   unMangleName(fileList)
 150           })
 151
 152 setMethod("dbDelete", signature(db = "filehashRDS", key = "character"),
 153           function(db, key, ...) {
 154                   ofile <- objectFile(db, key)
 155
 156                   ## remove/delete the file
 157                   status <- file.remove(ofile)
 158                   invisible(isTRUE(status))
 159           })
 160
 161 setMethod("dbUnlink", "filehashRDS",
 162           function(db, ...) {
 163                   ## delete the entire database directory
 164                   d <- db@dir
 165                   status <- unlink(d, recursive = TRUE)
 166                   invisible(status)
 167           })
 168