Skip to content

Commit 800b7ed

Browse files
lsteinmannlsteinmann
committed
refactor duplicate_by and add fraction to result
1 parent 6efac33 commit 800b7ed

4 files changed

Lines changed: 253 additions & 43 deletions

File tree

‎R/duplicate_by.R‎

Lines changed: 36 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -3,40 +3,48 @@
33
#' For each period one object may be placed in according to the range
44
#' provided by the `start` and `end` columns of the data.frame `data`, the
55
#' associated row is duplicated as many times as possible periods the objects
6-
#' might be placed in according to the concordance object supplied to
6+
#' might be placed in according to the concordance supplied to
77
#' `conc` ([make_chrongler_conc()]). This way, each objects is
8-
#' represented by multiple rows in the result!
8+
#' represented by multiple rows in the result! A `fraction` column tracks
9+
#' the resulting *fraction* or weight each row represents in regards to the object.
910
#'
1011
#'
1112
#' @inheritParams group_periods
12-
#' @param by_group *TRUE/FALSE*. Default is TRUE. If TRUE all rows are
13-
#' duplicated according to their grouped periods (see [group_periods()]). If
14-
#' FALSE all rows are duplicated according to their single
15-
#' periods (see [ungroup_periods()]).
13+
#' @param by_group *TRUE/FALSE*, _required_. Should the rows be duplicated along period
14+
#' groups? If `TRUE`: all rows are duplicated according to their grouped
15+
#' periods (see [group_periods()]). If `FALSE`: all rows are duplicated
16+
#' according to their single periods (see [ungroup_periods()]).
1617
#'
17-
#' @return A data.frame, with a row for each period in which each row from the
18-
#' previous data would fall (see description).
18+
#' @return The input `data` as a `data.frame`, with duplicated rows and additional columns:
19+
#' * `period` -- *ordered factor* of the period represented by this row.
20+
#' * `fraction` -- *numeric* value of 1 divided by the number of periods an
21+
#' object can belong to: the fraction of each object the row can represent.
22+
#' * Additional columns produced by [group_periods()] or [ungroup_periods()]
1923
#'
2024
#' @export
2125
#'
2226
#' @examples
2327
#' data("BuildingsMilet")
24-
#'
25-
#' filename <- system.file(package = "chrongler",
26-
#' "extdata/2023_periods_grouping_example.csv")
27-
#' conc <- make_chrongler_conc(filename)
28+
#' data("PeriodsMilet")
29+
#' conc <- make_chrongler_conc(PeriodsMilet)
2830
#'
2931
#' duplicate_by(BuildingsMilet, conc,
3032
#' start = "period.start", end = "period.end",
3133
#' by_group = FALSE)
3234
#'
33-
duplicate_by <- function(data, conc, start, end, by_group = TRUE) {
35+
duplicate_by <- function(data, conc, start, end, by_group) {
3436

3537
stopifnot(inherits(conc, "chrongler.conc"))
36-
3738
start <- colnames_to_index(colnames = colnames(data), columns = start)
3839
end <- colnames_to_index(colnames = colnames(data), columns = end)
3940

41+
if (missing(by_group)) {
42+
message("`by_group` is not set: defaulting to FALSE and duplicating by period. ",
43+
"Set `by_group = TRUE` to duplicate by period groups instead.")
44+
by_group <- FALSE
45+
}
46+
stopifnot(is.logical(by_group))
47+
4048
if (by_group == TRUE) {
4149
data <- group_periods(data, conc, start, end)
4250
order <- conc$group.order
@@ -45,35 +53,35 @@ duplicate_by <- function(data, conc, start, end, by_group = TRUE) {
4553
} else if (by_group == FALSE) {
4654
data <- ungroup_periods(data, conc, start, end)
4755
order <- conc$period.order
48-
start <- colnames_to_index(colnames(data), "start.ungr")
49-
end <- colnames_to_index(colnames(data), "end.ungr")
56+
start <- colnames_to_index(colnames = colnames(data),
57+
columns = "start.ungr")
58+
end <- colnames_to_index(colnames = colnames(data),
59+
columns = "end.ungr")
5060
}
5161

5262
data[, start] <- ordered(data[, start], levels = order)
5363
data[, end] <- ordered(data[, end], levels = order)
5464

55-
multiple <- split(data, seq_len(nrow(data)))
65+
per_row <- split(data, seq_len(nrow(data)))
5666

57-
multiple <- lapply(multiple, function (x) {
67+
per_row <- lapply(per_row, function (x) {
5868
from <- as.numeric(x[, start])
5969
to <- as.numeric(x[, end])
60-
if (is.na(from) | is.na(to)) {
61-
x$period <- NA
62-
x$rowname <- paste(rownames(x), "1", sep = ".")
70+
if (is.na(from) || is.na(to)) {
71+
x$period <- factor(NA, levels = order, ordered = TRUE)
72+
x$fraction <- NA_real_
6373
return(x)
6474
}
6575
sequence <- seq(from = from, to = to)
6676
new_periods <- order[sequence]
6777
repl <- rep(list(x), length(new_periods))
6878
repl <- do.call(rbind, repl)
6979
repl$period <- new_periods
70-
repl$rowname <- paste(rownames(x), seq_len(nrow(repl)), sep = ".")
71-
rownames(repl) <- repl$rowname
72-
repl
80+
repl$fraction <- 1 / nrow(repl)
81+
return(repl)
7382
})
74-
multiple <- do.call(rbind, multiple)
75-
rownames(multiple) <- multiple$rowname
76-
multiple$rowname <- NULL
83+
result <- do.call(rbind, per_row)
84+
rownames(result) <- NULL
7785

78-
return(multiple)
86+
return(result)
7987
}

‎TODO.md‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,4 @@
11
# WIP
2-
- Duplicating objects by periods also needs to attach the "fraction" of each object.
32
- Documentation of all functions
43

54
# Bugs
@@ -8,4 +7,3 @@
87
# Tests
98
- group_periods (no tests)
109
- ungroup_periods (no tests)
11-
- duplicate_by (no tests)

‎man/duplicate_by.Rd‎

Lines changed: 17 additions & 13 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎tests/testthat/test-duplicate_by.R‎

Lines changed: 200 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,200 @@
1+
## tests for duplicate_by, from duplicate_by.R
2+
3+
test_conc <- make_chrongler_conc(
4+
data.frame(
5+
values = c("Period 1", "Period 2", "Period 3", "Period 4"),
6+
group = c("Group A", "Group A", "Group B", "Group B"),
7+
dating.min = c(-100, -49, 100, 200),
8+
dating.max = c(-50, 99, 199, 300)
9+
)
10+
)
11+
12+
test_data <- data.frame(
13+
id = c("Obj_1", "Obj_2", "Obj_3"),
14+
period.start = c("Period 1", "Period 2", "Period 3"),
15+
period.end = c("Period 2", "Period 4", "Period 3")
16+
)
17+
18+
19+
#### Basics
20+
21+
test_that("fails if conc is not a chrongler.conc", {
22+
expect_error(
23+
duplicate_by(data = test_data, conc = list(1, 2, 3),
24+
start = "period.start", end = "period.end",
25+
by_group = FALSE),
26+
"chrongler.conc"
27+
)
28+
})
29+
30+
test_that("fails if column does not exist", {
31+
expect_error(
32+
duplicate_by(data = test_data, conc = test_conc,
33+
start = "not_a_column", end = "period.end",
34+
by_group = FALSE),
35+
"not_a_column"
36+
)
37+
expect_error(
38+
duplicate_by(data = test_data, conc = test_conc,
39+
start = "period.start", end = "not_a_column",
40+
by_group = FALSE),
41+
"not_a_column"
42+
)
43+
})
44+
45+
test_that("returns a data.frame", {
46+
result <- duplicate_by(data = test_data, conc = test_conc,
47+
start = "period.start", end = "period.end",
48+
by_group = FALSE)
49+
expect_true(is.data.frame(result))
50+
})
51+
52+
test_that("keeps other columns intact", {
53+
data <- test_data
54+
data$unrelated_column <- c("info_1", "info_2", "info_3")
55+
result <- duplicate_by(data = data, conc = test_conc,
56+
start = "period.start", end = "period.end",
57+
by_group = FALSE)
58+
expect_true("unrelated_column" %in% colnames(result))
59+
# Obj_1 spans 2 periods, so its unrelated_column value should appear twice
60+
expect_equal(sum(result$unrelated_column == "info_1"), 2)
61+
})
62+
63+
64+
#### Row counts
65+
66+
test_that("produces correct number of rows by period", {
67+
# Obj_1: Period 1 -> Period 2 = 2 rows
68+
# Obj_2: Period 2 -> Period 4 = 3 rows
69+
# Obj_3: Period 3 -> Period 3 = 1 row
70+
result <- duplicate_by(data = test_data, conc = test_conc,
71+
start = "period.start", end = "period.end",
72+
by_group = FALSE)
73+
expect_equal(nrow(result), 6)
74+
expect_equal(sum(result$id == "Obj_1"), 2)
75+
expect_equal(sum(result$id == "Obj_2"), 3)
76+
expect_equal(sum(result$id == "Obj_3"), 1)
77+
})
78+
79+
test_that("produces correct number of rows by group", {
80+
# Obj_1: Group A -> Group A = 1 row
81+
# Obj_2: Group A -> Group B = 2 rows
82+
# Obj_3: Group B -> Group B = 1 row
83+
result <- duplicate_by(data = test_data, conc = test_conc,
84+
start = "period.start", end = "period.end",
85+
by_group = TRUE)
86+
expect_equal(nrow(result), 4)
87+
expect_equal(sum(result$id == "Obj_1"), 1)
88+
expect_equal(sum(result$id == "Obj_2"), 2)
89+
expect_equal(sum(result$id == "Obj_3"), 1)
90+
})
91+
92+
93+
#### Period column
94+
95+
test_that("period column contains correct values by period", {
96+
result <- duplicate_by(data = test_data, conc = test_conc,
97+
start = "period.start", end = "period.end",
98+
by_group = FALSE)
99+
expect_true("period" %in% colnames(result))
100+
obj1_periods <- result$period[result$id == "Obj_1"]
101+
expect_equal(as.character(obj1_periods), c("Period 1", "Period 2"))
102+
obj2_periods <- result$period[result$id == "Obj_2"]
103+
expect_equal(as.character(obj2_periods), c("Period 2", "Period 3", "Period 4"))
104+
})
105+
106+
test_that("period column contains correct values by group", {
107+
result <- duplicate_by(data = test_data, conc = test_conc,
108+
start = "period.start", end = "period.end",
109+
by_group = TRUE)
110+
obj2_periods <- result$period[result$id == "Obj_2"]
111+
expect_equal(as.character(obj2_periods), c("Group A", "Group B"))
112+
})
113+
114+
test_that("period column is the correct ordered factor", {
115+
result <- duplicate_by(data = test_data, conc = test_conc,
116+
start = "period.start", end = "period.end",
117+
by_group = FALSE)
118+
expect_equal(
119+
levels(result$period),
120+
levels(test_conc$period.order)
121+
)
122+
expect_true(is.ordered(result$period))
123+
result <- duplicate_by(data = test_data, conc = test_conc,
124+
start = "period.start", end = "period.end",
125+
by_group = TRUE)
126+
expect_equal(
127+
levels(result$period),
128+
levels(test_conc$group.order)
129+
)
130+
expect_true(is.ordered(result$period))
131+
})
132+
133+
134+
#### Fraction column
135+
136+
test_that("fraction column is present", {
137+
result <- duplicate_by(data = test_data, conc = test_conc,
138+
start = "period.start", end = "period.end",
139+
by_group = FALSE)
140+
expect_true("fraction" %in% colnames(result))
141+
result <- duplicate_by(data = test_data, conc = test_conc,
142+
start = "period.start", end = "period.end",
143+
by_group = TRUE)
144+
expect_true("fraction" %in% colnames(result))
145+
})
146+
147+
test_that("fractions sum to 1 per original row", {
148+
result <- duplicate_by(data = test_data, conc = test_conc,
149+
start = "period.start", end = "period.end",
150+
by_group = FALSE)
151+
obj1_sum <- sum(result$fraction[result$id == "Obj_1"])
152+
obj2_sum <- sum(result$fraction[result$id == "Obj_2"])
153+
obj3_sum <- sum(result$fraction[result$id == "Obj_3"])
154+
expect_equal(obj1_sum, 1)
155+
expect_equal(obj2_sum, 1)
156+
expect_equal(obj3_sum, 1)
157+
})
158+
159+
test_that("fraction values are correct", {
160+
result <- duplicate_by(data = test_data, conc = test_conc,
161+
start = "period.start", end = "period.end",
162+
by_group = FALSE)
163+
# Obj_1 spans 2 periods: each gets 1/2
164+
expect_equal(unique(result$fraction[result$id == "Obj_1"]), 1/2)
165+
# Obj_2 spans 3 periods: each gets 1/3
166+
expect_equal(unique(result$fraction[result$id == "Obj_2"]), 1/3)
167+
# Obj_3 spans 1 period: gets 1
168+
expect_equal(unique(result$fraction[result$id == "Obj_3"]), 1)
169+
})
170+
171+
172+
#### NA handling
173+
# This test fails because ungroup_ and group_ are not able to handle NA
174+
test_that("NA start or end produces single row with NA period and NA fraction", {
175+
data <- data.frame(
176+
id = c("Obj_1", "Obj_2"),
177+
period.start = c(NA, "Period 1"),
178+
period.end = c("Period 2", NA)
179+
)
180+
result <- duplicate_by(data = data, conc = test_conc,
181+
start = "period.start", end = "period.end",
182+
by_group = FALSE)
183+
expect_equal(nrow(result), 2)
184+
expect_true(is.na(result$period[result$id == "Obj_1"]))
185+
expect_true(is.na(result$period[result$id == "Obj_2"]))
186+
expect_true(is.na(result$fraction[result$id == "Obj_1"]))
187+
expect_true(is.na(result$fraction[result$id == "Obj_2"]))
188+
})
189+
190+
191+
#### Row identity
192+
193+
test_that("original row data is preserved in duplicated rows", {
194+
result <- duplicate_by(data = test_data, conc = test_conc,
195+
start = "period.start", end = "period.end",
196+
by_group = FALSE)
197+
obj2_rows <- result[result$id == "Obj_2", ]
198+
# All three duplicated rows should have the same id
199+
expect_true(all(obj2_rows$id == "Obj_2"))
200+
})

0 commit comments

Comments
 (0)