Skip to content

Commit 7146488

Browse files
author
hoehleatsu
committedFeb 12, 2015
converted the time series conversion stuff to a package
1 parent 03d169e commit 7146488

12 files changed

+365
-1
lines changed
 

‎README.md

+4-1
Original file line numberDiff line numberDiff line change
@@ -1 +1,4 @@
1-
# hackout2
1+
# time group of the hackout2
2+
3+
Members:
4+

‎linelist2ts/.Rbuildignore

+2
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
^.*\.Rproj$
2+
^\.Rproj\.user$

‎linelist2ts/.gitignore

+3
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
.Rproj.user
2+
.Rhistory
3+
.RData

‎linelist2ts/DESCRIPTION

+9
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
Package: linelist2ts
2+
Title: Convert linelists to xts/zoo time series objects and display them.
3+
Version: 0.0.0.9000
4+
Authors@R: person("Michael", "Höhle", , "first.last@example.com", role = c("aut", "cre"))
5+
Description: What the package does (one paragraph)
6+
Depends: R (>= 3.1.2), OutbreakTools, xts, zoo
7+
License: What license is it under?
8+
LazyData: true
9+
Encoding: UTF8

‎linelist2ts/NAMESPACE

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
# Generated by roxygen2 (4.1.0): do not edit by hand
2+
3+
export(get.incidence2)
4+
export(inc2xts)
5+
exportMethods(get.incidence2)

‎linelist2ts/R/getIncidence.R

+172
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,172 @@
1+
#' Overwrites the get.incidence function for obkData objects to support doBy
2+
#'
3+
#' Creates different time series based on the list of factor variables.
4+
#' This function should eventually migrate back into the OutbreakTools package.
5+
#'
6+
#' @author Michael Höhle
7+
#' @export
8+
setGeneric("get.incidence2", function(x, ...) standardGeneric("get.incidence2"))
9+
10+
####################
11+
## obkData method ##
12+
####################
13+
##
14+
## based on 'dates' associated to a given field
15+
## 'values' are optional and can be used to subset the retained 'dates'
16+
## (e.g. define what a positive case is)
17+
18+
#' More powerful get.incidence method for obkData
19+
#'
20+
#' @export
21+
setMethod("get.incidence2", "obkData", function(x, data, where=NULL, val.min=NULL, val.max=NULL, val.kept=NULL, regexp=NULL,
22+
from=NULL, to=NULL, interval=1, add.zero=TRUE, doBy=NULL, ...){
23+
## HANDLE ARGUMENTS ##
24+
if(is.null(val.min)) val.min <- -Inf
25+
if(is.null(val.max)) val.max <- Inf
26+
27+
28+
## GET DATA ##
29+
df <- get.data(x, data=data, where=where, showSource=TRUE)
30+
if(is.null(df)) stop(paste("Data",data,"cannot be found in this obkData object"))
31+
32+
## call specific procedures if applicable ##
33+
if(inherits(df, c("obkSequences", "obkContacts"))) {
34+
return(get.incidence(df, from=from, to=to,
35+
interval=interval, add.zero=add.zero))
36+
}
37+
38+
39+
## OTHERWISE: DATA ASSUMED TAKEN FROM RECORDS ##
40+
## if data=='records', keep the first data.frame of the list ##
41+
if(is.list(df) && !is.data.frame(df) && is.data.frame(df[[1]])) df <- df[[1]]
42+
43+
## get dates ##
44+
if(!"date" %in% names(df)) stop("no date in the data")
45+
dates <- df$date
46+
47+
## get optional values associated to the dates ##
48+
## keep 'data' if it is there
49+
if(data %in% names(df)){
50+
values <- df[[data]]
51+
} else { ## else keep first optional field
52+
temp <- !names(df) %in% c("individualID","date") # fields being not "individualID" or "date"
53+
if(any(temp)) {
54+
values <- df[,min(which(temp))]
55+
} else {
56+
values <- NULL
57+
}
58+
}
59+
60+
61+
## EXTRACT RELEVANT DATES ##
62+
if(!is.null(values)){
63+
toKeep <- rep(TRUE, length(values))
64+
65+
## if 'values' is numeric ##
66+
if(is.numeric(values)){
67+
toKeep <- toKeep & (values>=val.min & values<=val.max)
68+
}
69+
70+
## if val.kept is provided ##
71+
if(!is.null(val.kept)) {
72+
toKeep <- toKeep & (values %in% val.kept)
73+
}
74+
75+
## if regexp is provided ##
76+
if(!is.null(regexp)) {
77+
temp <- rep(FALSE, length(values))
78+
temp[grep(regexp, values, ...)] <- TRUE
79+
toKeep <- toKeep & temp
80+
}
81+
82+
dates <- dates[toKeep]
83+
}
84+
85+
##If there are no dates we are done.
86+
if(length(dates)==0) return(NULL)
87+
88+
##Prepare the return list
89+
res <- list()
90+
91+
#If there is no from-to specification make
92+
#sure it's not data subset dependend, but is the
93+
#same for each subset.
94+
if (is.null(from) & is.null(to)) {
95+
from <- min(dates)
96+
to <- max(dates)
97+
}
98+
99+
##Loop over all variables in doBy
100+
if (!is.null(doBy)) {
101+
for (i in seq_len(length(doBy))) {
102+
# browser()
103+
theData <- get.data(x, data=doBy[[i]], showSource=TRUE)
104+
105+
if (is.null(theData)) stop(paste0("Data for ",doBy[[i]]," cannot be found in this obkData object."))
106+
if (!is.factor(theData[,doBy[[i]]])) stop("The variable ",doBy[[i]]," is not a factor.")
107+
108+
res[[doBy[i]]] <- tapply(dates, INDEX=theData[,doBy[[i]]], FUN=get.incidence, from=from, to=to, interval=interval, add.zero=add.zero,simplify=FALSE)
109+
}
110+
} else {
111+
res <- list(get.incidence(dates, from=from, to=to, interval=interval, add.zero=add.zero))
112+
}
113+
114+
## RETURN OUTPUT ##
115+
return(res)
116+
}) # end obkData method
117+
118+
#' Helper function to format a get.incidence list of data.frames
119+
#' to a multivariate xts object
120+
#'
121+
#' @param incList List of lists containing the data.frames from get.incidence2
122+
#' @return An xts object corresponding to the flattened incList
123+
#' @export
124+
inc2xts <- function(incList) {
125+
#Convert each entry of incList from data.frame to xts. It's a list of xts obj
126+
xtsList <- lapply(incList, function(list) {
127+
lapply(list, function(df) {
128+
with(df, as.xts(incidence, order.by=date))
129+
})
130+
})
131+
132+
#Code looping over all xts entries and merging them. data.table or plyr
133+
#might do this better?
134+
xts <- Reduce(cbind,lapply(xtsList, function(list) Reduce(cbind, list)))
135+
136+
#Manual way of getting pretty (?) column names
137+
lvl1 <- names(xtsList)
138+
lvl2 <- lapply(xtsList, names)
139+
mynames <- paste(rep(lvl1,times=sapply(lvl2,length)), do.call(c,lvl2),sep="-")
140+
dimnames(xts)[[2]] <- mynames
141+
142+
#Is there a better way?!?!
143+
144+
#Sanity checks
145+
#all(xtsList[["SEX"]]$male == xts[,"SEX-male"])
146+
#all(xtsList[["SEX"]]$female == xts[,"SEX-female"])
147+
#all(xtsList[["AGEGRP"]][[1]] == xts[,"AGEGRP-(0,5]"])
148+
149+
#xts <- Reduce(cbind, Reduce(cbind, xtsList))
150+
#do.call(cbind, xtsList)
151+
#data.table::rbindlist(xtsList)
152+
153+
return(xts)
154+
}
155+
156+
sandboxIt <- function() {
157+
source("getIncidence.R")
158+
159+
#Add extra column
160+
hagelloch.obk@individuals$AGEGRP <- cut(hagelloch.obk@individuals$AGE, breaks=c(0,5,10,Inf))
161+
162+
163+
inc <- get.incidence2(hagelloch.obk, "timeERU", doBy=c("SEX","CL"), add.zero=FALSE)
164+
165+
#Show the time series.
166+
plot(inc2xts(inc))
167+
plot(as.zoo(inc2xts(inc)),plot.type='multiple')
168+
plot(as.zoo(inc2xts(inc)), screens=1,col=c("magenta","steelblue"),lwd=3,type="h",cex.axis=0.8)
169+
170+
plot(as.zoo(inc2xts(inci)), plot.type='multiple')
171+
172+
}

‎linelist2ts/data/hagelloch.obk.R

+46
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,46 @@
1+
require("OutbreakTools")
2+
3+
#' Convert Hagelloch 1861 measles outbreak into obkData.
4+
#'
5+
#' Small converter function to take the hagelloch.df data.frame
6+
#' available in the surveillance package and make an obkData object
7+
#' out of it.
8+
#' @name hagelloch.obk
9+
#' @docType data
10+
#' @author Michael Höhle <http://www.math.su.se/~hoehle>
11+
#' @references \url{data_blah.com}
12+
#' @keywords data
13+
#' @details This function is not really one you would put in a package.
14+
#' Instead, the function would be called for it's output. See the surveillance package
15+
#' for a description of the data.
16+
17+
create.hagelloch.obk <- function() {
18+
#Use Hagelloch measles data (as available in the surveillance package) instead
19+
data("hagelloch", package="surveillance")
20+
21+
#The variable PN contains the ID, use the OutbreakTools name 'individualID' instead
22+
names(hagelloch.df)[pmatch("PN",names(hagelloch.df))] <- "individualID"
23+
#Remove the individual, which must have gotten infected for other sources than from the outbreak
24+
diff(sort(hagelloch.df$ERU))
25+
hagelloch.df <- hagelloch.df[-which.max(hagelloch.df$ERU),]
26+
nrow(hagelloch.df)
27+
28+
#Variables with date information in the Hagelloch data.set
29+
dateVars <- c("PRO", "ERU", "DEAD")
30+
records <- lapply(dateVars, function(varName) {
31+
data.frame(individualID=hagelloch.df$individualID, date=hagelloch.df[,varName])
32+
})
33+
#Give the list appropriate names (ensure names are not the same as in 'individuals')
34+
names(records) <- paste0("time",dateVars)
35+
36+
#Create obkData object
37+
hagelloch.obk <- new("obkData", individuals=hagelloch.df, records=records)
38+
39+
#Consistency checks
40+
class(foo <- get.dates(hagelloch.obk, data="records"))
41+
all.equal(hagelloch.obk@records$PRO$date,foo[1:nrow(hagelloch.df)])
42+
43+
return(hagelloch.obk)
44+
}
45+
46+
#hagelloch.obk <- create.hagelloch.obk()

‎linelist2ts/linelist2ts.Rproj

+21
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,21 @@
1+
Version: 1.0
2+
3+
RestoreWorkspace: No
4+
SaveWorkspace: No
5+
AlwaysSaveHistory: Default
6+
7+
EnableCodeIndexing: Yes
8+
UseSpacesForTab: Yes
9+
NumSpacesForTab: 2
10+
Encoding: UTF-8
11+
12+
RnwWeave: knitr
13+
LaTeX: pdfLaTeX
14+
15+
AutoAppendNewline: Yes
16+
StripTrailingWhitespace: Yes
17+
18+
BuildType: Package
19+
PackageUseDevtools: Yes
20+
PackageInstallArgs: --no-multiarch --with-keep.source
21+
PackageRoxygenize: rd,collate,namespace

‎linelist2ts/man/get.incidence2-obkData-method.Rd

+15
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
% Generated by roxygen2 (4.1.0): do not edit by hand
2+
% Please edit documentation in R/getIncidence.R
3+
\docType{methods}
4+
\name{get.incidence2,obkData-method}
5+
\alias{get.incidence2,obkData-method}
6+
\title{More powerful get.incidence method for obkData}
7+
\usage{
8+
\S4method{get.incidence2}{obkData}(x, data, where = NULL, val.min = NULL,
9+
val.max = NULL, val.kept = NULL, regexp = NULL, from = NULL,
10+
to = NULL, interval = 1, add.zero = TRUE, doBy = NULL, ...)
11+
}
12+
\description{
13+
More powerful get.incidence method for obkData
14+
}
15+

‎linelist2ts/man/get.incidence2.Rd

+16
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
% Generated by roxygen2 (4.1.0): do not edit by hand
2+
% Please edit documentation in R/getIncidence.R
3+
\name{get.incidence2}
4+
\alias{get.incidence2}
5+
\title{Overwrites the get.incidence function for obkData objects to support doBy}
6+
\usage{
7+
get.incidence2(x, ...)
8+
}
9+
\description{
10+
Creates different time series based on the list of factor variables.
11+
This function should eventually migrate back into the OutbreakTools package.
12+
}
13+
\author{
14+
Michael Höhle
15+
}
16+

‎linelist2ts/man/inc2xts.Rd

+20
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
% Generated by roxygen2 (4.1.0): do not edit by hand
2+
% Please edit documentation in R/getIncidence.R
3+
\name{inc2xts}
4+
\alias{inc2xts}
5+
\title{Helper function to format a get.incidence list of data.frames
6+
to a multivariate xts object}
7+
\usage{
8+
inc2xts(incList)
9+
}
10+
\arguments{
11+
\item{incList}{List of lists containing the data.frames from get.incidence2}
12+
}
13+
\value{
14+
An xts object corresponding to the flattened incList
15+
}
16+
\description{
17+
Helper function to format a get.incidence list of data.frames
18+
to a multivariate xts object
19+
}
20+

‎linelist2ts/test/sandbox.R

+52
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,52 @@
1+
#' None package material experimental code for getting incidence curves.
2+
#'
3+
#' @author Michael Höhle <http://www.math.su.se/~hoehle>
4+
#'
5+
6+
#Load the package itself.
7+
library("linelist2ts")
8+
#Load extra libraries for the visualization
9+
library("dygraphs")
10+
library("RColorBrewer")
11+
library("scales")
12+
library("ggplot2")
13+
14+
#Load example data form Hagelloch 1861 measles outbreak
15+
data("hagelloch.obk")
16+
17+
#Create extra factor variable for AGEGRPS
18+
hagelloch.obk@individuals$AGEGRP <- cut(hagelloch.obk@individuals$AGE, breaks=c(0,5,10,Inf))
19+
20+
#Todo: Aggregate like a boss (using formula interface) as follows:
21+
#
22+
# get.incidence2(hagelloch.obk, timeERU ~ SEX)
23+
#
24+
#inc <- get.incidence(hagelloch.obk, "timeERU", doBy=c("SEX","AGEGRP"), add.zero=FALSE)
25+
inc <- get.incidence2(hagelloch.obk, "timeERU", doBy=c("SEX","CL"), add.zero=FALSE)
26+
27+
#Convert incList to xts object and plot (ToDo: improve using dplyr?)
28+
sts.xts <- inc2xts(inc)
29+
30+
################## plot.zoo visualization ################
31+
pal <- brewer.pal(n=ncol(sts.xts),"Set3")
32+
plot(as.zoo(sts.xts), plot.type="single",col=pal,lwd=3,xlab="Onset of rash",ylab="No. individuals",type="l")
33+
grid(ny=NULL,nx=NA,col="darkgray")
34+
legend(x="topleft",colnames(sts.xts),col=pal,lwd=3)
35+
36+
##########ggplot2 like plots from zoo objects ############
37+
#(see http://stackoverflow.com/questions/13848218/drawing-a-multiline-graph-with-ggplot2-from-a-zoo-object)
38+
p <- autoplot(sts.xts, facet = NULL)
39+
p
40+
p + aes(linetype = NULL)
41+
p + scale_x_date(labels = date_format("%d-%b"), xlab("Onset of rash")) + scale_y_continuous(ylab("No. individuals"))
42+
43+
############# Interactive graphics using dygraph ###########
44+
#You can click and drag to zoom. Double-clicking will zoom you back out. Shift-drag will pan
45+
#See also: http://dygraphs.com/
46+
foo <- dygraph(sts.xts, main = "Hagelloch") %>%
47+
dyRangeSelector(dateWindow = range(index(sts.xts)))
48+
foo
49+
50+
#Add some clickCallback handler - note that the alert function is javascript
51+
foo$x$attrs$clickCallback = htmlwidgets::JS('function(e,x,pts) { alert(JSON.stringify(pts))}')
52+
foo

0 commit comments

Comments
 (0)
Please sign in to comment.