-
Notifications
You must be signed in to change notification settings - Fork 9
/
sfcr_matrix_display.R
141 lines (114 loc) · 4.72 KB
/
sfcr_matrix_display.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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
#' Find names for display matrix
#'
#' Clean cells to display in latex format
#'
#' @param matrix A balance-sheet or transactions-flow matrix
#'
#' @author João Macalós
#'
#' @keywords internal
#'
.find_names <- function(matrix) {
p1 <- matrix %>%
dplyr::mutate(dplyr::across(-1, ~gsub("\\+|\\-|\\*|\\/|\\(|\\)|\\[-1\\]", " ", .x))) %>%
dplyr::mutate(dplyr::across(-1, ~stringr::str_squish(.x))) %>%
dplyr::mutate(dplyr::across(-1, ~stringr::str_split(.x, " "))) %>%
dplyr::mutate(dplyr::across(-1, ~purrr::map(.x, function(y) unique(y))))
nms <- unlist(p1[, -1])
nms[purrr::map_lgl(nms, ~!(.x %in% c("", "0")))]
}
#' Transform entries into latex style
#'
#' @param matrix a balance-sheet or transactions-flow matrix
#' @param nms Cleaned names with \code{.find_names()}
#'
#' @author João Macalós
#'
#' @keywords internal
#'
.to_latex_style <- function(matrix, nms) {
# Dictionary to remove numbers from names
words <- c("_zero_", "_one_", "_two_", "_three_", "_four_", "_five_", "_six_", "_seven_", "_eight_", "_nine_")
n_words <- as.character(0:9)
names(n_words) <- words
names(words) <- n_words
# Load existing names in the matrix
v <- nms
# English numbers
v <- stringr::str_replace_all(v, purrr::imap_chr(words, ~{.y = .x}))
v2 <- as.character(seq_along(v))
names(v2) <- v
v2 <- rev(v2[order(nchar(names(v2)), v2)])
v3 <- v
names(v3) <- as.character(seq_along(v))
#pat <- "\\(([[:digit:]]{1,})-[[:digit:]]{1,}\\[-1\\]\\)"
pat <- "\\(([[:digit:]]{1,})-[[:digit:]]{1,}\\[-_one_\\]\\)"
matrix <- matrix %>%
dplyr::mutate(dplyr::across(-1, ~stringr::str_replace_all(.x, "d\\((.*?)\\)", "\\(\\1 - \\1\\[-1\\]\\)"))) %>%
dplyr::mutate(dplyr::across(-1, ~stringr::str_replace_all(.x, "_", "\\\\_"))) %>%
dplyr::mutate(dplyr::across(-1, ~gsub(" ", "", .x))) %>%
dplyr::mutate(dplyr::across(-1, ~stringr::str_replace_all(.x, purrr::imap_chr(words, function(x, y) y = x)))) %>%
dplyr::mutate(dplyr::across(-1, ~stringr::str_replace_all(.x, purrr::imap_chr(v2, function(x, y) y = x)))) %>%
dplyr::mutate(dplyr::across(-1, ~gsub(pat, "\\\\Delta \\1", .x, perl = T))) %>%
dplyr::mutate(dplyr::across(-1, ~stringr::str_replace_all(.x, purrr::imap_chr(rev(v3), function(x, y) y = x)))) %>%
dplyr::mutate(dplyr::across(-1, ~stringr::str_replace_all(.x, purrr::imap_chr(n_words, function(x, y) y = x)))) %>%
dplyr::mutate(dplyr::across(-1, ~gsub("(.*)", "$\\1$", .x))) %>%
dplyr::mutate(dplyr::across(-1, ~gsub("\\$\\$", "", .x))) %>%
dplyr::mutate(dplyr::across(-1, ~gsub("\\*", "\\\\cdot ", .x))) %>%
dplyr::mutate(dplyr::across(-1, ~gsub("\\[-1\\]", "_{-1}", .x)))
zero_row <- matrix[1, ]
zero_row <- purrr::modify(zero_row, ~ "$0$")
zero_row[[1]] <- "$\\sum$"
matrix <- matrix %>%
rbind(zero_row)
return(matrix)
}
#' Print matrix to screen
#'
#' @param matrix A balance sheet or transactions-flow matrix
#' @param which A character string for the matrix. Is it a balance-sheet or
#' a transactions-flow matrix? here are two options:
#' \code{"bs"} for balance-sheet matrices, and \code{"tfm"} for transactions-
#' flow matrices. The default is \code{"tfm"}.
#'
#' @details This function takes a matrix as input and generate a \code{kableExtra}
#' table with math symbols displayed in latex style.
#'
#' @note This function converts the math expressions used to build the \code{sfcr_matrix}
#' into a latex format, but cannot add modifications to it. The user is
#' invited to explore the source code and the \code{kableExtra} package in order to
#' personalize his/her own matrices.
#'
#' @example inst/examples/example_sfcr_matrix_display.R
#'
#' @author João Macalós
#'
#'
#' @export
sfcr_matrix_display <- function(matrix, which = "tfm") {
match.arg(which, c("tfm", "bs"))
# if (!requireNamespace("kableExtra", quietly = TRUE)) {
# stop("Packages \"kableExtra\" needed for this function to work. Please install it.",
# call. = FALSE)
# }
# Make sure that first column is named "name"
nms_matrix <- colnames(matrix)
colnames(matrix) <- c("name", nms_matrix[2:length(nms_matrix)])
nms <- .find_names(matrix)
latex <- .to_latex_style(matrix, nms)
nms_latex <- colnames(latex)
if (which == "tfm") {
latex <- latex %>%
dplyr::mutate(sum = "$0$") %>%
purrr::set_names(c("", nms_latex[2:length(nms_latex)], "$\\sum$"))
} else {
latex <- latex %>%
dplyr::mutate(dplyr::across(ncol(latex), ~dplyr::if_else(stringr::str_length(.x) == 0, "$0$", .x))) %>%
purrr::set_names(c("", nms_latex[2:(length(nms_latex) - 1)], "$\\sum$"))
}
kableExtra::kbl(latex,
format = "html",
table.attr = "style = \"color: black;\""
) %>%
kableExtra::kable_styling(c("striped", "hover"), full_width = FALSE)
}