-
Notifications
You must be signed in to change notification settings - Fork 4
/
sbtscs.R
117 lines (116 loc) · 4.5 KB
/
sbtscs.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
#' Create "peace years" or "spells" by cross-sectional unit
#'
#' @description \code{sbtscs()} allows you to create spells ("peace years" in
#' the international conflict context) between observations of some event. This
#' will allow the researcher to better model temporal dependence in binary time-series
#' cross-section ("BTSCS") models.
#'
#' @details I should confess outright, and it should be obvious to anyone
#' who looks at the code, that I liberally copy from Dave Armstrong's
#' \code{btscs()} function in the \pkg{DAMisc} package. I offer two such improvements.
#' One, the \code{btscs()} function chokes when a large number of cross-sectional units
#' have no recorded "event." I don't know why this happens but it does. Further, "tidying"
#' up the code by leaning on \pkg{dplyr} substantially speeds up computation. Incidentally,
#' this concerns the same cross-sectional units with no recorded events that can choke the
#' \code{btscs()} function in large numbers.
#'
#' @return \code{sbtscs()} takes a data frame and returns the data frame with a new variable
#' named \code{spell}.
#'
#' @author David A. Armstrong, Steven V. Miller
#'
#' @references Armstrong, Dave. 2016. ``\pkg{DAMisc}: Dave Armstrong's Miscellaneous Functions.''
#' \emph{R package version 1.4-3}.
#'
#' Miller, Steven V. 2017. ``Quickly Create Peace Years for BTSCS Models with \code{sbtscs} in \code{stevemisc}.''
#' \url{http://svmiller.com/blog/2017/06/quickly-create-peace-years-for-btscs-models-with-stevemisc/}
#'
#' @param data the data set with which you are working
#' @param event some event (0, 1) for which you want spells or peace years
#' @param tvar the time variable (e.g. a year)
#' @param csunit the cross-sectional unit (likely a dyad if you're doing boilerplate international conflict stuff)
#' @param pad_ts should time-series be filled when panels are unbalanced/have gaps? Defaults to FALSE.
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(stevemisc)
#' data(usa_mids)
#'
#' # notice: no quotes
#' sbtscs(usa_mids, midongoing, year, dyad)
#' }
#'
sbtscs <- function(data, event, tvar, csunit, pad_ts = FALSE) {
tvar <- enquo(tvar)
event <- enquo(event)
csunit <- enquo(csunit)
data <- arrange(data, !!csunit, !!tvar)
sumevents <- data %>%
group_by(!!csunit) %>%
mutate(tot = sum(!!event, na.rm=T))
noevents <- sumevents %>%
group_by(!!csunit) %>%
filter(.data$tot == 0) %>%
mutate(spell = seq_along(!!tvar) - 1)
data <- sumevents %>%
group_by(!!csunit) %>%
filter(.data$tot > 0) %>%
as.data.frame()
tvar <- quo_name(tvar)
event <- quo_name(event)
csunit <- quo_name(csunit)
# Taken from Dave Armstrong's DAMisc package.
data$orig_order <- 1:nrow(data)
data <- data[order(data[[csunit]], data[[tvar]]), ]
spells <- function(x) {
tmp <- rep(0, length(x))
runcount <- 0
for (j in 2:length(x)) {
if (x[j] == 0 & x[(j - 1)] == 0) {
tmp[j] <- runcount <- runcount + 1
}
if (x[j] != 0 & x[(j - 1)] == 0) {
tmp[j] <- runcount + 1
runcount <- 0
}
if (x[j] == 0 & x[(j - 1)] != 0) {
tmp[j] <- runcount <- 0
}
}
tmp
}
sp <- split(data, data[[csunit]])
if (pad_ts) {
sp <- lapply(sp, function(x) x[match(seq(min(x[[tvar]], na.rm = T), max(x[[tvar]], na.rm = T)),
x[[tvar]]), ])
for (i in 1:length(sp)) {
if (any(is.na(sp[[i]][[event]]))) {
sp[[i]][[event]][which(is.na(sp[[i]][[event]]))] <- 1
}
if (any(is.na(sp[[i]][[tvar]]))) {
sp[[i]][[tvar]] <- seq(min(sp[[i]][[tvar]], na.rm = T), max(sp[[i]][[tvar]], na.rm = T))
}
if (any(is.na(sp[[i]][[csunit]]))) {
sp[[i]][[csunit]][which(is.na(sp[[i]][[csunit]]))] <- mean(sp[[i]][[csunit]], na.rm = T)
}
}
}
sp <- lapply(1:length(sp), function(x) {
cbind(sp[[x]], data.frame(spell = spells(sp[[x]][[event]])))
})
data <- do.call(rbind, sp)
if (!pad_ts) {
if (any(is.na(data$orig_order))) {
data <- data[-which(is.na(data$orig_order)), ]
}
data <- data[data$orig_order, ]
} else {
data <- data[order(data[[csunit]], data[[tvar]]), ]
}
data$orig_order <- NULL
data <- bind_rows(data, noevents)
data$tot <- NULL
data <- as_tibble(data[order(data[[csunit]], data[[tvar]]), ])
return(data)
}