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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
#' Gets the number of `rgroup` HTML line
#'
#' @param total_columns The total number of columns including the `rowlabel` and the
#' spacer cells
#' @param cspan The column span of the current `rgroup`
#' @param style The css style corresponding to the `rgroup` css style that includes
#' the color specific for the `rgroup`, i.e. `col.rgroup`.
#' @param cgroup_spacer_cells The vector indicating the position of the `cgroup`
#' spacer cells
#' @param prepped_row_css The `css.cell` information for this particular row.
#' @param rgroup_iterator An integer indicating the `rgroup`
#' @inheritParams htmlTable
#' @keywords internal
prGetRgroupLine <- function(x,
total_columns = NULL,
rgroup = NULL,
rgroup_iterator = NULL,
cspan = NULL,
rnames = NULL,
style = NULL,
cgroup_spacer_cells = NULL,
style_list = NULL,
prepped_row_css = NULL) {
ret_str <- ""
rgroup_elmnt <- rgroup[rgroup_iterator]
add_elmnt <- prAttr4RgroupAdd(
rgroup = rgroup,
rgroup_iterator = rgroup_iterator,
no_cols = ncol(x)
)
## this will allow either css.rgroup or col.rgroup to
## color the rgroup label rows
if (is.numeric(cspan) &&
cspan < ncol(x) ||
!is.null(add_elmnt)) {
filler_cells <- rep("", ncol(x))
if (!is.null(add_elmnt)) {
if (!is.numeric(cspan)) {
cspan <- ncol(x) + 1 * !prSkipRownames(rnames)
}
if (length(add_elmnt) > 1) {
if (is.null(names(add_elmnt))) {
stop(
"The rgroup 'add' attribute element no '", rgroup_iterator, "'",
" either be a single element or a named list/vector"
)
}
add_pos <- as.integer(names(add_elmnt))
if (any(is.na(add_pos)) ||
any(add_pos < 1) ||
any(add_pos > ncol(x))) {
stop(
"You have provided invalid element position for rgroup = '", rgroup_elmnt, "'",
" the attribute seeems to be a list but the names are invalid",
" '", paste(names(add_elmnt), collapse = "', '"), "'",
" they should be integers between 1 and ", ncol(x)
)
}
first_pos <- min(add_pos) - 1 + 1 * !prSkipRownames(rnames)
if (is.null(cspan)) {
cspan <- first_pos
} else {
cspan <- min(
cspan,
first_pos
)
}
for (ii in 1:length(add_pos)) {
filler_cells[add_pos[ii]] <- add_elmnt[[ii]]
}
} else if (length(add_elmnt) == 1) {
if (is.null(names(add_elmnt)) ||
names(add_elmnt) == "last") {
add_pos <- ncol(x)
} else {
add_pos <- as.integer(names(add_elmnt))
if (is.na(add_pos) ||
add_pos < 1 ||
add_pos > ncol(x)) {
stop(
"You have provided invalid element position for rgroup = '", rgroup_elmnt, "'",
" the attribute seeems to be a list but the name is invalid",
" '", names(add_elmnt), "'",
" it should be an integer between 1 and ", ncol(x)
)
}
}
first_pos <- add_pos - 1 + 1 * !prSkipRownames(rnames)
if (is.null(cspan)) {
cspan <- first_pos
} else {
cspan <- min(
cspan,
first_pos
)
}
filler_cells[add_pos] <- add_elmnt
} else {
stop(
"The attribute to the rgroup '", rgroup_elmnt, "'",
" does not have a length!"
)
}
}
true_span <- cspan +
sum(cgroup_spacer_cells[0:(cspan - 1 * !prSkipRownames(rnames))]) * prGetEmptySpacerCellSize(style_list = style_list)
ret_str %<>%
sprintf(
"%s\n\t<tr><td colspan='%d' style='%s'>%s</td>",
.,
true_span,
prGetStyle(style),
paste0(
style_list$padding.tspanner,
rgroup_elmnt
)
)
cols_left <- ncol(x) - (cspan - 1 * !prSkipRownames(rnames))
cell_str <- prAddCells(
rowcells = filler_cells,
cellcode = "td",
style_list = style_list,
style = style,
cgroup_spacer_cells = cgroup_spacer_cells,
has_rn_col = !prSkipRownames(rnames) * 1,
offset = ncol(x) - cols_left + 1,
prepped_cell_css = prepped_row_css
)
ret_str %<>%
paste0(cell_str)
ret_str %<>% paste0("</tr>")
} else {
ret_str %<>%
sprintf(
"%s\n\t<tr><td colspan='%d' style='%s'>%s</td></tr>",
.,
total_columns,
prGetStyle(style),
paste0(
style_list$padding.tspanner,
rgroup_elmnt
)
)
}
return(ret_str)
}
|
