-
Notifications
You must be signed in to change notification settings - Fork 32
/
CellBlock.R
312 lines (282 loc) · 11.7 KB
/
CellBlock.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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
# Cell Block functionality. This is to be used when writing to a spreadsheet.
#
#
#' Create and style a block of cells.
#'
#' Functions to create and style (not read) a block of cells. Use it to
#' set/update cell values and cell styles in an efficient manner.
#'
#'
#' Introduced in version 0.5.0 of the package, these functions speed up the
#' creation and styling of cells that are part of a "cell block" (a rectangular
#' shaped group of cells). Use the functions above if you want to create
#' efficiently a complex sheet with many styles. A simple by-column styling
#' can be done by directly using \code{\link{addDataFrame}}. With the
#' functionality provided here you can efficiently style individual cells, see
#' the example.
#'
#' It is difficult to treat \code{NA}'s consistently between R and Excel via
#' Java. Most likely, users of Excel will want to see \code{NA}'s as blank
#' cells. In R character \code{NA}'s are simply characters, which for Excel
#' means "NA".
#'
#' If you try to set more data to the block than you have cells in the block,
#' only the existing cells will be set.
#'
#' Note that when modifying the style of a group of cells, the changes are made
#' to the pairs defined by \code{(rowIndex, colIndex)}. This implies that the
#' length of \code{rowIndex} and \code{colIndex} are the same value. An
#' exception is made when either \code{rowIndex} or \code{colIndex} have length
#' one, when they will be expanded internally to match the length of the other
#' index.
#'
#' Function \code{CB.setMatrixData} works for numeric or character matrices.
#' If the matrix \code{x} is not of numeric type it will be converted to a
#' character matrix.
#'
#' @param sheet a \code{\link{Sheet}} object.
#' @param startRow a numeric value for the starting row.
#' @param startColumn a numeric value for the starting column.
#' @param rowOffset a numeric value for the starting row.
#' @param colOffset a numeric value for the starting column.
#' @param showNA a logical value. If set to \code{FALSE}, NA values will be
#' left as empty cells.
#' @param noRows a numeric value to specify the number of rows for the block.
#' @param noColumns a numeric value to specify the number of columns for the
#' block.
#' @param create If \code{TRUE} cells will be created if they don't exist, if
#' \code{FALSE} only existing cells will be used. If cells don't exist (on a
#' new sheet for example), you have to use \code{TRUE}. On an existing sheet
#' with data, use \code{TRUE} if you want to blank out an existing cell block.
#' Use \code{FALSE} if you want to keep the styling of existing cells, but just
#' modify the value of the cell.
#' @param cellBlock a cell block object as returned by \code{\link{CellBlock}}.
#' @param rowStyle a \code{\link{CellStyle}} object used to style the row.
#' @param colStyle a \code{\link{CellStyle}} object used to style the column.
#' @param cellStyle a \code{\link{CellStyle}} object.
#' @param border a Border object, as returned by \code{\link{Border}}.
#' @param fill a Fill object, as returned by \code{\link{Fill}}.
#' @param font a Font object, as returned by \code{\link{Font}}.
#' @param colIndex a numeric vector specifiying the columns you want relative
#' to the \code{startColumn}.
#' @param rowIndex a numeric vector specifiying the rows you want relative to
#' the \code{startRow}.
#' @param x the data you want to add to the cell block, a vector or a matrix
#' depending on the function.
#' @return For \code{CellBlock} a cell block object.
#'
#' For \code{CB.setColData}, \code{CB.setRowData}, \code{CB.setMatrixData},
#' \code{CB.setFill}, \code{CB.setFont}, \code{CB.setBorder} nothing as he
#' modification to the workbook is done in place.
#' @author Adrian Dragulescu
#' @examples
#'
#' \donttest{
#' wb <- createWorkbook()
#' sheet <- createSheet(wb, sheetName="CellBlock")
#'
#' cb <- CellBlock(sheet, 7, 3, 1000, 60)
#' CB.setColData(cb, 1:100, 1) # set a column
#' CB.setRowData(cb, 1:50, 1) # set a row
#'
#' # add a matrix, and style it
#' cs <- CellStyle(wb) + DataFormat("#,##0.00")
#' x <- matrix(rnorm(900*45), nrow=900)
#' CB.setMatrixData(cb, x, 10, 4, cellStyle=cs)
#'
#' # highlight the negative numbers in red
#' fill <- Fill(foregroundColor = "red", backgroundColor="red")
#' ind <- which(x < 0, arr.ind=TRUE)
#' CB.setFill(cb, fill, ind[,1]+9, ind[,2]+3) # note the indices offset
#'
#' # set the border on the top row of the Cell Block
#' border <- Border(color="blue", position=c("TOP", "BOTTOM"),
#' pen=c("BORDER_THIN", "BORDER_THICK"))
#' CB.setBorder(cb, border, 1, 1:1000)
#'
#'
#' # Don't forget to save the workbook ...
#' # saveWorkbook(wb, file)
#' }
#'
#' @export
CellBlock <- function(sheet, startRow, startColumn, noRows, noColumns,
create=TRUE) UseMethod("CellBlock")
#' @export
#' @rdname CellBlock
is.CellBlock <- function(cellBlock) {inherits(cellBlock, "CellBlock")}
#########################################################################
# Create a cell block
#
#' @export
#' @rdname CellBlock
CellBlock.default <- function(sheet, startRow, startColumn, noRows, noColumns,
create=TRUE)
{
cb <- new(J("org/cran/rexcel/RCellBlock"), sheet, as.integer(startRow-1),
as.integer(startColumn-1), as.integer(noRows), as.integer(noColumns),
create)
structure(list(ref=cb), class="CellBlock")
}
#########################################################################
# set the column data for a Cell Block
#
#' @export
#' @rdname CellBlock
CB.setColData <- function(cellBlock, x, colIndex, rowOffset=0, showNA=TRUE,
colStyle=NULL)
{
.jcall( cellBlock$ref, "V", "setColData", as.integer(colIndex-1),
as.integer(rowOffset), .jarray(x), showNA,
if ( !is.null(colStyle) ) colStyle$ref else
.jnull('org/apache/poi/ss/usermodel/CellStyle') )
}
#########################################################################
# set the row data for a Cell Block
#
#' @export
#' @rdname CellBlock
CB.setRowData <- function(cellBlock, x, rowIndex, colOffset=0, showNA=TRUE,
rowStyle=NULL)
{
.jcall( cellBlock$ref, "V", "setRowData", as.integer(rowIndex-1),
as.integer(colOffset), .jarray(as.character(x)), showNA,
if ( !is.null(rowStyle) ) rowStyle$ref else
.jnull('org/apache/poi/ss/usermodel/CellStyle') )
}
#########################################################################
# set a matrix of data for a Cell Block.
# if x is not a numeric matrix, coerce it a character matrix
#
#' @export
#' @rdname CellBlock
CB.setMatrixData <- function(cellBlock, x, startRow, startColumn,
showNA=TRUE, cellStyle=NULL)
{
endRow <- startRow + dim(x)[1] - 1
endColumn <- startColumn + dim(x)[2] - 1
if ( (endRow-startRow+1) > .jfield(cellBlock$ref, "I", "noRows") )
stop("The rows of x don't fit in the cellBlock!")
if ( (endColumn-startColumn+1) > .jfield(cellBlock$ref, "I", "noCols") )
stop("The columns of x don't fit in the cellBlock!")
if (class(x[1,1])[1] == "numeric") {
.jcall( cellBlock$ref, "V", "setMatrixData", as.integer(startRow-1),
as.integer(endRow-1), as.integer(startColumn-1), as.integer(endColumn-1),
.jarray(x), showNA,
if ( !is.null(cellStyle) ) cellStyle$ref else
.jnull('org/apache/poi/ss/usermodel/CellStyle') )
} else {
.jcall( cellBlock$ref, "V", "setMatrixData", as.integer(startRow-1),
as.integer(endRow-1), as.integer(startColumn-1), as.integer(endColumn-1),
.jarray(as.character(x)), showNA,
if ( !is.null(cellStyle) ) cellStyle$ref else
.jnull('org/apache/poi/ss/usermodel/CellStyle') )
}
}
#########################################################################
# set the Fill for an array of indices of a Cell Block
#
#' @export
#' @rdname CellBlock
CB.setFill <- function( cellBlock, fill, rowIndex, colIndex)
{
if (length(colIndex)==1 & length(rowIndex) > 1)
colIndex <- rep(colIndex, length(rowIndex))
if (length(rowIndex)==1 & length(colIndex) > 1)
rowIndex <- rep(rowIndex, length(colIndex))
if (length(rowIndex) != length(colIndex))
stop("rowIndex and colIndex arguments don't have the same length!")
if ( cellBlock$ref$isXSSF() ) {
.jcall( cellBlock$ref, 'V', 'setFill',
.xssfcolor( fill$foregroundColor ),
.xssfcolor( fill$backgroundColor ),
.jshort(FILL_STYLES_[[fill$pattern]]),
.jarray( as.integer( rowIndex-1 ) ),
.jarray( as.integer( colIndex-1 ) ) )
} else {
.jcall( cellBlock$ref, 'V', 'setFill',
.hssfcolor( fill$foregroundColor ),
.hssfcolor( fill$backgroundColor ),
.jshort(FILL_STYLES_[[fill$pattern]]),
.jarray( as.integer( rowIndex-1 ) ),
.jarray( as.integer( colIndex-1 ) ) )
}
invisible()
}
#########################################################################
# set the Font for an array of indices of a Cell Block
#
#' @export
#' @rdname CellBlock
CB.setFont <- function( cellBlock, font, rowIndex, colIndex )
{
if (length(colIndex)==1 & length(rowIndex) > 1)
colIndex <- rep(colIndex, length(rowIndex))
if (length(rowIndex)==1 & length(colIndex) > 1)
rowIndex <- rep(rowIndex, length(colIndex))
if (length(rowIndex) != length(colIndex))
stop("rowIndex and colIndex arguments don't have the same length!")
.jcall( cellBlock$ref, 'V', 'setFont', font$ref,
.jarray( as.integer( rowIndex-1 ) ),
.jarray( as.integer( colIndex-1 ) ) )
invisible()
}
#########################################################################
# set the Border for an array of indices of a Cell Block
#
#' @export
#' @rdname CellBlock
CB.setBorder <- function( cellBlock, border, rowIndex, colIndex)
{
if (length(colIndex)==1 & length(rowIndex) > 1)
colIndex <- rep(colIndex, length(rowIndex))
if (length(rowIndex)==1 & length(colIndex) > 1)
rowIndex <- rep(rowIndex, length(colIndex))
if (length(rowIndex) != length(colIndex))
stop("rowIndex and colIndex arguments don't have the same length!")
isXSSF <- .jcall( cellBlock$ref, 'Z', 'isXSSF' )
border_none <- BORDER_STYLES_[['BORDER_NONE']]
borders <- c( TOP = border_none,
BOTTOM = border_none,
LEFT = border_none,
RIGHT = border_none )
borders[ border$position ] <- sapply( border$pen,
function( pen ) BORDER_STYLES_[pen] )
null_color <- if (isXSSF) {
.jnull('org/apache/poi/xssf/usermodel/XSSFColor')
} else {
0
}
border_colors <- c( TOP = null_color,
BOTTOM = null_color,
LEFT = null_color,
RIGHT = null_color )
border_colors[ border$position ] <- .Rcolor2XLcolor( border$color, isXSSF)
if ( isXSSF ) {
.jcall( cellBlock$ref, "V", "putBorder",
.jshort(borders[['TOP']]), border_colors[['TOP']],
.jshort(borders[['BOTTOM']]), border_colors[['BOTTOM']],
.jshort(borders[['LEFT']]), border_colors[['LEFT']],
.jshort(borders[['RIGHT']]), border_colors[['RIGHT']],
.jarray( as.integer( rowIndex-1L ) ),
.jarray( as.integer( colIndex-1L ) ) )
} else {
.jcall( cellBlock$ref, "V", "putBorder",
.jshort(borders[['TOP']]), .jshort(border_colors[['TOP']]),
.jshort(borders[['BOTTOM']]), .jshort(border_colors[['BOTTOM']]),
.jshort(borders[['LEFT']]), .jshort(border_colors[['LEFT']]),
.jshort(borders[['RIGHT']]), .jshort(border_colors[['RIGHT']]),
.jarray( as.integer( rowIndex-1L ) ),
.jarray( as.integer( colIndex-1L ) ) )
}
invisible()
}
############################################################################
# get reference to java cell object by its CellBlock row and column indices
# DON'T NEED TO EXPOSE THIS it's just: cb$ref$getCell(1L, 1L)
## CB.getCell <- function( cellBlock, rowIndex, colIndex )
## {
## invisible(
## .jcall( cellBlock$ref, 'Lorg/apache/poi/ss/usermodel/Cell;', 'getCell',
## rowIndex - 1L, colIndex - 1L ) )
## }