travis test

DESCRIPTION

@@ -12,7 +12,9 @@ Depends:
     reshape2,
     data.table,
     yaml,
-    pander
+    pander,
+    RPostgreSQL,
+    sqldf
 License: GPL-2.0
 Suggests:
     testthat
@@ -47,6 +49,7 @@ Collate:
     'record2table.r'
     'selectIndex.r'
     'select_data.r'
+    'sql_demographic.r'
     'stdid.r'
     'unique.patient.r'
     'unique.spell.R'

Makefile

@@ -7,3 +7,4 @@ test:
 
 clean:
 	rm -rf src/*.o src/*.so
+	rm -rf man

NAMESPACE

@@ -48,6 +48,11 @@ export(reindexRecord)
 export(selectTable)
 export(select_data)
 export(setValue)
+export(sql.add.demographic)
+export(sql.demographic.table)
+export(sql.init.postgres)
+export(sql.load_file)
+export(sql.newdb)
 export(unique.spell)
 export(uniquePatients)
 export(xml2Data)

R/selectIndex.r

@@ -32,7 +32,7 @@ selectIndex<- function(ids, type){
     return(ccdata.env$checklist[[id]])
 }
 
-#'
+#' 
 #' @export .which.datatype
 .which.datatype <- function(id) {
   # List with the convertion operations to do for each datatype
@@ -53,5 +53,12 @@ selectIndex<- function(ids, type){
   }
   # accounts for not listed or null (eg. when working with dt labels)
   return(as.character)
+}
+
 
+#' Convert item data to its corresponding data type.
+#' @param id NHIC code of the data
+#' @param vals The vector of values of the item.
+#' @return vector values in its corresponding data type
+which.datatype <- function(id, vals) {
 }

R/sql_demographic.r

@@ -0,0 +1,78 @@
+#' Create demographic SQL tables. The data type of each column is in its
+#' corresponding data type.
+#' @export sql.demographic.table
+sql.demographic.table <- function(record, dtype=TRUE) {
+    env <- environment()
+    demogls <- list()
+    all.demcode <- all.nhic.code("Demographic")
+    for_each_episode(record, 
+        function(x){
+            demog.data <- rep("NULL", length(all.demcode))
+            names(demog.data) <- all.demcode
+            demog.data <- as.list(demog.data)
+            for(item in names(x@data)) {
+                if (length(x@data[[item]]) == 1) {
+                    demog.data[[item]] <- x@data[[item]]
+                }
+            }
+            env$demogls[[length(env$demogls) + 1]] <- .simple.data.frame(demog.data)
+        })
+    demogt <- rbindlist(demogls)
+    setnames(demogt, code2stname(names(demogt)))
+
+    if (dtype) {
+        for (i in seq(ncol(demogt))){
+            demogt[[i]] <- 
+                .which.datatype(stname2code(names(demogt)[i]))(demogt[[i]])
+        }
+    }
+    return(demogt)
+}
+
+
+#' Initialise the connection of between sqldf and postgres.
+#' @export sql.init.postgres
+sql.init.postgres <- function() {
+    options(sqldf.RPostgreSQL.user ="sinan", 
+            sqldf.RPostgreSQL.dbname ="postgres",
+            sqldf.RPostgreSQL.host ="localhost",
+            sqldf.RPostgreSQL.port =5432)
+}
+
+#' Load SQL command from a file in which the SQL commands are recorded.
+#' @param path the full path of the SQL file.
+#' @return a string of command.
+#' @export sql.load_file
+sql.load_file <- function(path) {
+    sqlfile <- file(path)
+    cmd <- paste(readLines(path), collapse="")
+    close(sqlfile)
+    return(cmd)
+}
+
+#' Remove all the existing tables from the database and load the new schema
+#' file.
+#' @param schema is the full path of the selected schema file.
+#' @export sql.newdb
+sql.newdb <- function(schema=NULL) {
+    if (is.null(schema))
+        schema <- paste(find.package("ccdata"), "sql/create_table.sql", sep="/") 
+
+    sql.init.postgres()
+    cmd <- sql.load_file(schema)
+    sqldf(cmd)
+}
+
+#' Add demographic table to the postgreSQL table.
+#' @param record
+#' @export sql.add.demographic
+sql.add.demographic <- function(record) {
+    sql.init.postgres()
+    sqldf('DROP TABLE IF EXISTS demographic;')
+    drv <- dbDriver("PostgreSQL")
+    con <- dbConnect(drv, host="localhost", user="sinan", dbname="postgres")
+    demogt <- sql.demographic.table(record, dtype=TRUE)
+    dbWriteTable(con, "demographic", demogt)
+    dbDisconnect(con)
+    invisible(demogt)
+}

R/stdid.r

@@ -46,3 +46,23 @@ as.number <- function(obj) {
 .as.number <- function(code) {
     return(as.numeric(strsplit(code, "NIHR_HIC_ICU_")[[1]][2]))
 }
+
+
+all.nhic.code <- function(cls) {
+        data.checklist[data.checklist$Classification1 == cls,"NHICcode"]
+}
+
+code2stname <- function(code) {
+    ccdata.env$code2stname.dict[code]
+}
+
+stname2code <- function(stname) {
+    ccdata.env$stname2code.dict[stname]
+}
+
+short2longname <- function(stname) {
+    longname <- array("NULL", length(stname))
+    for (i in seq_along(stname))
+        longname[i] <- ccdata.env$ITEM_REF[[stname2code(stname[i])]]$dataItem
+    return(longname)
+}

R/zzz.r

@@ -1,9 +1,22 @@
 .onLoad <- function(libname = find.package("ccdata"), pkgname = "ccdata") {
     ccdata.env <<- new.env()
-    path <- find.package("ccdata")
 
+    reverse.name.value <- function(vec) {
+        new <- names(vec)
+        names(new) <- vec
+        return(new)
+    }
+    path <- find.package("ccdata")
     data("data.checklist", package="ccdata")
-    ccdata.env$ITEM_REF <- yaml.load_file(paste(path, "data", "ITEM_REF.yaml", sep=.Platform$file.sep))
+
+    ITEM_REF <- yaml.load_file(paste(path, "data", "ITEM_REF.yaml", sep=.Platform$file.sep))
+    code2stname.dict <- sapply(ITEM_REF, function(x) x$shortName)
+    stname2code.dict <- reverse.name.value(code2stname.dict)
+
+    ccdata.env$ITEM_REF <- ITEM_REF
+    ccdata.env$code2stname.dict <- code2stname.dict
+    ccdata.env$stname2code.dict <- stname2code.dict
+
 
     assign('code_pas_number',  getItemInfo("PAS number")["NHIC_code"], envir=ccdata.env)
     assign('code_nhs_number',  getItemInfo("NHS number")["NHIC_code"], envir=ccdata.env)