Relationship Duration Summary
Adam Elder
2021-01-19
0.1 Tracking of relationship duration and age
During the simulation, as ties form and dissolve, this information is stored inside of the dat object. However, because of the large number of relationships that occur during an entire simulation, the list of relationships is trimmed each year to prevent the dat object from becoming too large.
0.2 What is calculated
- The mean relationship age of ties that currently exist at the end of the year.
- The mean relationship duration of ties that ended in the past year.
- The mean relationship duration of all ties that have ever ended (after a certain year).
0.3 Where calculations occur
Each year information on relationship duration is stored inside of the temp object. This information is created by the calculate_part_dist function which is stored inside of the whamp_util.R script. These calculations are based on the plist object. This object has information on
- The id for each node in the tie.
- The relationship type (which network the tie is a part of).
- The step when the relationship started,
- The step when the relationship ended (if it has ended).
Averages of relationship duration and age are taken for both ongoing and ended relationships for both main and casual relationships.
- This function is called inside of the prevalence_msm function.
suppressPackageStartupMessages(library(tidyverse))
dat_obj <- readRDS("../../EpiModel/AE/sim_epimodel3/sim_at_2013_2021-01-13.rds")## Registered S3 method overwritten by 'tergm':
## method from
## simulate_formula.network ergm# nest_obj <- readRDS("../../Data/stergmFits/netest_mc_hiv_caxr_whamp3.rds")
options(dplyr.summarise.inform = FALSE)
rd <- dat_obj$temp$rel_dur
rd$type <- "Simulated"0.4 Mean relationship duration during simulation
all_ended <- rd %>% filter(ong == "ended", at > 520) %>% group_by(ptype) %>%
mutate(rel_dur = cumsum((rel_dur * num_obs)[order(at)])/
cumsum((num_obs)[order(at)]),
ong = "ended_tot")
rd <- rbind(rd, all_ended)
epistats <- readRDS("../../Data/epistats_whamp.rds")
#rel_ages <- c(epistats$relage.main$wtd.mean / 52,
# epistats$relage.casl$wtd.mean / 52)
# rel_durs <- c(epistats$relduration.main$wtd.mean / 52,
# epistats$relduration.casl$wtd.mean / 52)
main_mean_relage <-
as.numeric(1/(1 - (2^(-1/(epistats$relage.main$wtd.median)))))
casl_mean_relage <-
as.numeric(1/(1 - (2^(-1/(epistats$relage.casl$wtd.median)))))
rel_ages <- c(main_mean_relage, casl_mean_relage) / 52
# targ_durs <- data.frame(ptype = 1:2, ong = "ended",
# rel_dur = rel_durs[1:2],
# type = "Weighted Survey Responses")
targ_ages <- data.frame(ptype = 1:2, ong = NA,
rel_dur = rel_ages[1:2],
type = "Weighted Survey Responses")
ggplot(rd, aes(color = ong, linetype = type)) +
geom_line(aes(x = at / 52 + 1943, y = rel_dur), size = 1) +
geom_hline(data = targ_ages,
aes(color = ong, linetype = type, yintercept = rel_dur),
size = 1) +
facet_wrap(~ptype, labeller = as_labeller(c(`1` = "Main", `2` = "Casual"))) +
xlab("Year") + ggtitle("Mean Relationship Duration (in Years)") +
coord_cartesian(ylim = c(1.5, 5.5)) +
scale_color_discrete(
name = "Status",
labels = c("ong" = "Still Ongoing (rel_age)",
"ended" = "Ended in Last Year (rel_dur)",
"ended_tot" = "All Completed Relationships")) +
scale_linetype_manual(name = "Source",
values = c("solid", "dotted")) +
cowplot::theme_cowplot() +
theme(legend.position = "bottom", axis.title = element_blank(),
legend.box = "vertical", legend.margin = margin(),
panel.background = element_rect(fill = "#E0E2E7"),
panel.grid = element_line(color = "#FFFFFF", size = 0.4))
0.5 Observed Mean Durations at the end of simulation
last_step <- rd %>% filter(at == max(rd$at)) %>% select(ptype, ong, rel_dur)
last_step$ong <- dplyr::recode(last_step$ong, ong = "Ongoing at Last time Step",
ended = "Ended in Last Year",
ended_tot = "All Completed Relationships")
target <- targ_ages %>% mutate(ong = "Target") %>% select(-type)
frst_tble <- bind_rows(target, last_step)
frst_tble$ptype <- c("Main", "Casual")[frst_tble$ptype]
frst_tble$rel_dur <- round(frst_tble$rel_dur, 2)
tble <- frst_tble %>% pivot_wider(names_from = ptype, values_from = rel_dur)
gt::gt(tble) %>% gt::cols_label(ong = " ", Main = "Main Relationships",
Casual = "Casual Relationships") %>%
gt::tab_header(
title = "Mean Relationship Durations in Years",
subtitle = "Target comes from Netest object and other values are based on EpiModel simulation"
) %>%
gt::tab_style(
style = gt::cell_text(weight = "bold"),
locations = gt::cells_body(rows = ong == "Target")
)| Mean Relationship Durations in Years | ||
|---|---|---|
| Target comes from Netest object and other values are based on EpiModel simulation | ||
| Main Relationships | Casual Relationships | |
| Target | 4.82 | 2.29 |
| Ended in Last Year | 3.65 | 1.79 |
| Ongoing at Last time Step | 3.45 | 1.93 |
| All Completed Relationships | 3.62 | 1.81 |
0.6 Distribution of relationship duration at end step
For these plots, the histogram provides the observed distribution, and the red and blue lines are the expected probability density of relationship duration under an exponential model with the observed and target mean duration respectively.
plist <- dat_obj$temp$plist %>% as.data.frame()
plist$ong <- "ended"
plist$ong[is.na(plist$stop)] <- "ong"
plist$stop[is.na(plist$stop)] <- max(plist$stop, na.rm = TRUE)
plist$length <- round(pmax(0, (plist$stop - (plist$start - 1)) / 52))
plist$flr_length <- floor(pmax(0, (plist$stop - (plist$start - 1)) / 52))
n_plist <- plist %>% filter(ptype != 3, flr_length < 25) %>%
group_by(ptype, ong, length = flr_length) %>%
count() %>% ungroup() %>% group_by(ptype, ong) %>%
mutate(prop = n / sum(n))
durs <- plist %>% filter(ptype != 3) %>%
group_by(ptype, ong) %>%
summarise(rel_dur = pmax(0, mean((stop - start) / 52)),
type = "Observed")
targ_durs <- data.frame(ptype = c(1, 1, 2, 2),
ong = c("ended", "ong",
"ended", "ong"),
rel_dur = rep(rel_ages, each = 2),
type = "Target")
durs <- bind_rows(durs, targ_durs)
exp_fits <- durs %>%
mutate(num = max(n_plist$length) + 1) %>%
uncount(weights = num, .id = "length") %>%
mutate(length = length - 1) %>%
mutate(prop = dexp(x = length + 0.5, rate = 1 / rel_dur))
ggplot(n_plist, aes(x = length, y = prop)) +
geom_line(data = exp_fits, aes(color = type), alpha = 1) +
geom_col(alpha = 0.5) +
facet_grid(
ptype ~ ong,
labeller = as_labeller(c(`1` = "Main", `2` = "Casual",
`ong` = "Still ongoing at end",
`ended` = "Ended in Last Year"))) +
xlab("Relationship Duration") + ylab("Proportion") + labs(
caption = "Lines represent exponential fits based on the target mean duration and the \n observed mean duraiton in the EpiModel simulation at the last step"
)
0.7 Session Info
sessionInfo()## R version 4.0.2 (2020-06-22)
## Platform: x86_64-apple-darwin17.0 (64-bit)
## Running under: macOS 10.16
##
## Matrix products: default
## BLAS: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRblas.dylib
## LAPACK: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRlapack.dylib
##
## locale:
## [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
##
## attached base packages:
## [1] stats graphics grDevices utils datasets methods base
##
## other attached packages:
## [1] forcats_0.5.0 stringr_1.4.0 dplyr_1.0.2 purrr_0.3.4
## [5] readr_1.3.1 tidyr_1.1.2 tibble_3.0.4 ggplot2_3.3.2
## [9] tidyverse_1.3.0
##
## loaded via a namespace (and not attached):
## [1] nlme_3.1-148 fs_1.4.2 lubridate_1.7.9
## [4] doParallel_1.0.15 RColorBrewer_1.1-2 httr_1.4.2
## [7] rprojroot_1.3-2 tools_4.0.2 backports_1.1.10
## [10] R6_2.5.0 DBI_1.1.0 lazyeval_0.2.2
## [13] colorspace_1.4-1 withr_2.3.0 tidyselect_1.1.0
## [16] compiler_4.0.2 ergm.multi_4.0-3965 cli_2.2.0
## [19] rvest_0.3.6 gt_0.2.2 xml2_1.3.2
## [22] network_1.17.0-585 sass_0.2.0 labeling_0.3
## [25] checkmate_2.0.0 scales_1.1.1 DEoptimR_1.0-8
## [28] robustbase_0.93-6 digest_0.6.27 rmarkdown_2.4
## [31] networkDynamic_0.10.2 pkgconfig_2.0.3 htmltools_0.5.0
## [34] egonet_0.0.1.0 dbplyr_1.4.4 rlang_0.4.9
## [37] readxl_1.3.1 rstudioapi_0.11 farver_2.0.3
## [40] generics_0.1.0 jsonlite_1.7.1 statnet.common_4.4.0-300
## [43] magrittr_2.0.1 Matrix_1.2-18 Rcpp_1.0.5
## [46] munsell_0.5.0 fansi_0.4.1 ape_5.4-1
## [49] lifecycle_0.2.0 stringi_1.5.3 yaml_2.2.1
## [52] MASS_7.3-51.6 grid_4.0.2 blob_1.2.1
## [55] parallel_4.0.2 crayon_1.3.4 lattice_0.20-41
## [58] cowplot_1.0.0 haven_2.3.1 splines_4.0.2
## [61] hms_0.5.3 knitr_1.30 pillar_1.4.7
## [64] EpiModel_2.0.3 codetools_0.2-16 lpSolve_5.6.15
## [67] rle_0.9.2-223 srvyr_0.3.10 reprex_0.3.0
## [70] glue_1.4.2 evaluate_0.14 trust_0.1-8
## [73] mitools_2.4 modelr_0.1.8 deSolve_1.28
## [76] vctrs_0.3.6 foreach_1.5.0 cellranger_1.1.0
## [79] gtable_0.3.0 assertthat_0.2.1 tergmLite_2.2.0
## [82] tergm_4.0.0-2013 xfun_0.18 broom_0.7.1
## [85] survey_4.0 ergm_4.0-5824 coda_0.19-4
## [88] survival_3.2-7 iterators_1.0.12 ellipsis_0.3.1
## [91] here_0.1