decoy_ugly.Rmd

Ugly DECOY
==========


```{r echo=FALSE}

options(width=180)
```

## Access to the Babel Clinical Data Warehouse

```{r babel.access,echo=FALSE}
# see install_RPostgres.Rmd for bleeding-edge details
library(DBI)
library(RPostgres)

# based on DBI::getQuery and RPostgres::dbSendQuery
# https://github.com/rstats-db/DBI/blob/7a0ad76dea21a846cee62f67108ab8e8b7d60a49/R/DBConnection.R#L133
makePreparedQuery <- function(conn) {
  function(statement, ...) {
    params = list(...)

    rs <- dbSendQuery(conn, statement)
    on.exit(dbClearResult(rs))
    
    if (length(params) > 0) {
      dbBind(rs, params)
      }
    
    df <- dbFetch(rs, n = -1, ...)
    if (!dbHasCompleted(rs)) {
      warning("Pending rows", call. = FALSE)
      }
    
    df
    }
  }



regparts <- function(needle, pattern) {
  m <- regexpr(pattern, needle, perl=TRUE)
  capture <- list(names=attr(m, 'capture.names'),
                  start=attr(m, 'capture.start'),
                  length=attr(m, 'capture.length'))
  x <- list()
  for (i in 1:length(capture$names)) {
    x[[capture$names[i]]] <- substr(needle, capture$start[i], capture$start[i] + capture$length[i] - 1)
  }
  x
}


babel.access <- function(env_key='CDW_URL',
                         getenv=Sys.getenv) {
  creds <- regparts(getenv(env_key),
         '^postgres://(?P<user>[^:]+):(?P<password>[^@]+)@(?P<host>[^:]+):(?P<port>\\d+)/(?P<dbname>.+)')

  function() {
    dbConnect(RPostgres::Postgres(),
              user=creds$user, password=creds$password, host=creds$host, port=creds$port, dbname=creds$dbname)
    }
  }
```

Put your credentials in the environment a la:

```{r}
Sys.setenv(CDW_URL='postgres://me:lemmein@babel:5432/i2b2')
```

where 5000 is the local end of an ssh tunnel to babel's postgres port (5432).

Then we can get a connection and run SQL queries:

```{r cdw}
myAccess = babel.access('CDW_URL')
cdw = myAccess()
dbGetQuery(cdw, "select 1+1")
```

The indirection thru `myAccess` encapsulates your credentials from your
exploratory computing session.

`makePreparedQuery` is a convenience function for using bind parameters.

```{r}
cdwq <- makePreparedQuery(cdw)
cdwq("select 2 + 2")
cdwq("select $1 + 5", p1=3)
```


## Basic Demographics

There are quite a few metadata tables:

```{r}
table_access <- cdwq(
  "select distinct c_name, c_table_name, c_fullname, c_totalnum
  from i2b2metadata.table_access")

nrow(table_access)
```

Let's pick out the ones relevant to demographics:

```{r}
dem_tables <- table_access[grep('demog', table_access$c_name, ignore.case=TRUE), ]
head(dem_tables)
```


### Age distribution

Next, we summarize age distribution:

*TODO: more than just KUMC*

```{r summary_nominal}

summary_nominal <- function(table, path_pattern) {
  cdwq(
    sub('&&TABLE', table,
        "select coalesce(sum(c_totalnum), 0) pat_qty, c_fullname, c_basecode
        from i2b2metadata.&&TABLE meta
        where meta.c_fullname like ('%' || $1 || '%') escape '$'
        and length(c_basecode) > 0
        group by c_fullname, c_basecode"),
    p1=path_pattern)
  }

age_dist <- summary_nominal(dem_tables[grep('KUMC', dem_tables$c_name),]$c_table_name, 'Demographics\\Age\\_')
age_dist$age <- as.numeric(sub('DEM|AGE:', '', age_dist$c_basecode, fixed=TRUE))
head(age_dist)
```

*something odd happens above 88 yrs old; let's leave that aside for the plot...*

```{r age.plot}
with(subset(age_dist, age < 88),
     plot(age, pat_qty))
```


### Sex distribution

*TODO: standard sex codes*

```{r}
sex_dist <- summary_nominal(dem_tables[grep('KUMC', dem_tables$c_name),]$c_table_name, 'Demographics\\Gender\\_')

last_char <- function(s) substr(s, nchar(s), nchar(s))
sex_dist$sex <- last_char(sex_dist$c_basecode)
sex_dist
```


```{r}
with(sex_dist, barplot(pat_qty, names.arg=sex))
```


## Synthesize patients

```{r synpat}

synpat <- function(qty, age_dist, sex_dist) {
  pat <- data.frame(patient_num=1:qty)
  pat$age <- with(age_dist, sample(age, qty, prob=pat_qty, replace=TRUE))
  pat$sex <- with(sex_dist, sample(sex, qty, prob=pat_qty, replace=TRUE))
  pat
  }

spat <- synpat(100, age_dist, sex_dist)
head(spat)
```


## Save patients in CSV format

```{r write_patients}
write.csv(spat, file="patient.csv", row.names=FALSE)
```