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
|
#' @export
#' @title Fix border issues when cells are merged
#' @description When cells are merged, the rendered borders will be those
#' of the first cell. If a column is made of three merged cells, the bottom
#' border that will be seen will be the bottom border of the first cell in the
#' column. From a user point of view, this is wrong, the bottom should be the one
#' defined for cell 3. This function modify the border values to avoid that effect.
#'
#' Note since version `0.9.7` that the function is called automatically
#' before rendering, user should not have to call this function anymore.
#' @inheritParams args_x_part
#' @examples
#' library(officer)
#' dat <- data.frame(a = 1:5, b = 6:10)
#' ft <- flextable(dat)
#' ft <- theme_box(ft)
#' ft <- merge_at(ft, i = 4:5, j = 1, part = "body")
#' ft <- hline(ft,
#' i = 5, part = "body",
#' border = fp_border(color = "red", width = 5)
#' )
#' print(ft)
#' ft <- fix_border_issues(ft)
#' print(ft)
#' @keywords internal
fix_border_issues <- function(x, part = "all") {
if (!inherits(x, "flextable")) {
stop(sprintf("Function `%s` supports only flextable objects.", "fix_border_issues()"))
}
part <- match.arg(part, c("all", "body", "header", "footer"), several.ok = FALSE)
if (part == "all") {
for (p in c("header", "body", "footer")) {
x <- fix_border_issues(x = x, part = p)
}
return(x)
}
if (nrow_part(x, part) < 1) {
return(x)
}
x[[part]] <- correct_h_border(x[[part]])
x[[part]] <- correct_v_border(x[[part]])
x
}
correct_h_border <- function(x) {
span_cols <- as.list(as.data.frame(x$spans$columns))
bool_to_be_corrected <- lapply(span_cols, function(x) x > 1)
l_apply_bottom_border <- lapply(span_cols, function(x) {
rle_ <- rle(x)
from <- cumsum(rle_$lengths)[rle_$values < 1]
to <- cumsum(rle_$lengths)[rle_$values > 1]
list(from = from, to = to, dont = length(to) < 1)
})
for (j in seq_len(ncol(x$spans$columns))) {
apply_bottom_border <- l_apply_bottom_border[[j]]
if (apply_bottom_border$dont) next
for (i in seq_along(apply_bottom_border$from)) {
i_from <- apply_bottom_border$from[i]
i_to <- apply_bottom_border$to[i]
x$styles$cells$border.color.bottom$data[i_to, x$col_keys[j]] <- x$styles$cells$border.color.bottom$data[i_from, x$col_keys[j]]
x$styles$cells$border.width.bottom$data[i_to, x$col_keys[j]] <- x$styles$cells$border.width.bottom$data[i_from, x$col_keys[j]]
x$styles$cells$border.style.bottom$data[i_to, x$col_keys[j]] <- x$styles$cells$border.style.bottom$data[i_from, x$col_keys[j]]
}
}
x
}
correct_v_border <- function(x) {
span_rows <- as.list(as.data.frame(t(x$spans$rows)))
l_apply_right_border <- lapply(span_rows, function(x) {
rle_ <- rle(x)
from <- cumsum(rle_$lengths)[rle_$values < 1]
to <- cumsum(rle_$lengths)[rle_$values > 1]
list(from = from, to = to, dont = length(to) < 1)
})
for (i in seq_along(l_apply_right_border)) {
apply_right_border <- l_apply_right_border[[i]]
if (apply_right_border$dont) next
for (j in seq_along(apply_right_border$from)) {
colkeyto <- x$col_keys[apply_right_border$to[j]]
colkeyfrom <- x$col_keys[apply_right_border$from[j]]
x$styles$cells$border.color.right$data[i, colkeyto] <- x$styles$cells$border.color.right$data[i, colkeyfrom]
x$styles$cells$border.width.right$data[i, colkeyto] <- x$styles$cells$border.width.right$data[i, colkeyfrom]
x$styles$cells$border.style.right$data[i, colkeyto] <- x$styles$cells$border.style.right$data[i, colkeyfrom]
}
}
x
}
|
