-
Notifications
You must be signed in to change notification settings - Fork 0
/
FillExcelTemplate.R
658 lines (597 loc) · 32.8 KB
/
FillExcelTemplate.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
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
Tabelle_bearbeiten <- function(table,startingPoints,nrEmptyRows){
## Leerzeilen hinzufuegen:
for(i in 1:length(startingPoints)){
#cat("i:",i,"\n")
if(is.vector(table)){
table <- as.matrix(table,ncol = 1)
}
leerzeile <- rep(NA,ncol(table))
if(nrEmptyRows[i]>1){
leerzeile <- matrix(rep(NA,ncol(table)*nrEmptyRows[i]),nrow=nrEmptyRows[i])
}
if(i==1){
startrow <- 0
}else{
startrow=1
}
if(ncol(table)==1){
table <- rbind(as.matrix(table[startrow:(startingPoints[i]-nrEmptyRows[i]-1),]),
leerzeile,
as.matrix(table[(startingPoints[i]-nrEmptyRows[i]):nrow(table),]))
}else{
table <- rbind(table[startrow:(startingPoints[i]-nrEmptyRows[i]-1),],
leerzeile,
table[(startingPoints[i]-nrEmptyRows[i]):nrow(table),])
}
}
rownames(table)[rownames(table)=="leerzeile"] <- ""
return(table)
}
seqle <- function(x,incr=1) {
if(!is.numeric(x)) x <- as.numeric(x)
n <- length(x)
y <- x[-1L] != x[-n] + incr
i <- c(which(y|is.na(y)),n)
list(lengths = diff(c(0L,i)),
values = x[head(c(0L,i)+1L,-1L)])
}
#table <- customCol
###?? setMissingValue(wb, value = "missing")
#' Funktion befuellt ein Excel Template.
#'
#' Funktion liest ein Excel-File ein, uebernimmt die Formatvorlage eines ausgewaehlten
#' Template-Excel-Sheets, befuellt die Kopie dieses Template-Excel-Sheets mit den Ergebnissen aus \link{MakeTable} und liest
#' das Ergebnis samt urspruenglichem Template-Excel-Sheet (default) und dem neu befuellten Excel-Sheet wieder als
#' Excel-File aus.
#'
#' Ein Template-Excel-Sheet, das als Vorlage fuer das zu befuellende Excel-Sheet dient
#' und i.d.R. leer ist bis auf einige Formate, Header und Rownames, wird durch ein Prefix im Sheet-Namen
#' gekennzeichnet (\code{prefixTSN}). Der Sheet-Name ist bis auf das Prefix identisch
#' zum Sheet-Namen des zu befuellenden neuen Excel-Sheets. Sollte entweder Template oder
#' zu befuellendes neues Excel-Sheet noch nicht existieren, wird es automatisch
#' angelegt. Die Template-Sheets koennen bei Bedarf wieder einzeln (\code{removeTemplateSheet})
#' oder alle auf einmal (removeAllTemplates) geloescht werden. Sollten sowohl das Template
#' als auch das neue Sheet im File schon existieren ist es irrelevant ob bei \code{sheet}
#' das Template oder das neue Sheet angegeben wird.
#'
#' Derzeit funktioniert diese Funktion nur fuer die Default-Werte von
#' \code{markLeft1}, \code{markRight1}, \code{markValue1}, \code{markLeft2},
#' \code{markRight2} und \code{markValue2} aus \code{MakeTable()} und
#' \code{MakeAKETimeInstantsTable()}.
#'
#' @param tab1 eine mit \code{MakeTable()} bzw.
#' \code{MakeAKETimeInstantsTable()} erzeugte Tabelle. Falls bei
#' \code{MakeTable()} limits angegeben und einzelne Zellen mit Klammern oder
#' Aehnlichem belegt wurden muss auch tab2 angegeben werden damit man die Werte
#' in den Zellen bekommt.
#' @param tab2 NULL oder eine mit \code{MakeTable()} bzw.
#' \code{MakeAKETimeInstantsTable()} erzeugte Tabelle bei der limits NICHT
#' angegeben wurden. Diese Tabelle muss immer uebergeben werden wenn fuer die
#' Erstellung von tab1 limits beruecksichtigt wurden.
#' @param startingPoints numerischer Vektor: die Startzeilen der befuellten
#' Zeilen nach Leerzeilen im Original-Excel-File.
#' @param nrEmptyRows numerischer Vektor: Anzahl an Leerzeilen die vor
#' \code{startingPoints} kommen sollen; eigentlich immer 1 ausser vor grossen
#' Bloecken.
#' @param inheritTemplateColNr numerischer Vektor oder NULL: Spaltennummer/n der Tabellenspalten die vom Original-Excel-File uebernommen werden sollen.
#' Default ist die erste Spalte, also \code{inheritTemplateColNr=1}.
#' @param customColNr numerischer Wert: Spaltennummer der Tabellenspalte (derzeit nur EINE moeglich) die ueber
#' \code{customCol} individuell definiert werden soll und bei der die Leerzeilen
#' im Gegensatz zum Parameter \code{customCellList}
#' aus \code{startingPoints} und \code{nrEmptyRows} uebernommen werden sollen.
#' Die Aufteilung von \code{tab1} auf die Spalten der Excel-Tabelle wird dann automatisch angepasst,
#' \code{tab1} bzw. \code{inheritTemplateColNr} wird also nicht ueberschrieben.
#' @param customCol character Vektor: Enthaelt die Eintraege der durch \code{customColNr}
#' definierten Tabellenspalte - falls diese nicht aus dem Original-Excel-File uebernommen werden sollen
#' und auch nicht durch \code{MakeTable()} generiert werden.
#' Im Gegensatz zum Parameter \code{customCellList} wird hier ein Character Vektor OHNE Missings uebergeben,
#' d.h. die ueber die Parameter \code{startingPoints} und \code{nrEmptyRows} definierten Leerzeilen
#' werden einfach uebernommen und muessen nicht extra beruecksichtigt werden.
#' Die Aufteilung von \code{tab1} auf die Spalten der Excel-Tabelle wird dann automatisch angepasst,
#' \code{tab1} bzw. \code{inheritTemplateColNr} wird also nicht ueberschrieben.
#' @param customCellList Listenobjekt: eine Liste (bzw. falls mehrere Zellen ueberschrieben werden sollen, eine Liste mit Sublisten) mit den Listenelementen
#' \code{row} (numeric), \code{col} (numeric) und \code{entry} (character).
#' Diese Listenelemente legen fest, welcher Zeile (row) und Spalte (col) die jeweilige Zelle entspricht
#' und was dort eingetragen werden soll (entry).
#' Um genau zu sein, legen \code{row} und \code{col} die jeweilige Start-Zeile und Start-Spalte in der Excel-Tabelle fest.
#' Somit koennen auch ganze Tabellenzeilen/-spalten auf einmal ueberschrieben werden,
#' dazu muss in \code{entry} lediglich ein Vektor der richtigen Laenge uebergeben werden. Siehe Examples.
#'
#' Dieser Parameter ist anzuwenden falls eine (oder mehrere) Zellen individuell angepasst werden sollen,
#' z.B. um eine Fussnote einzufuegen oder um die Eintraege einer bestimmten Tabellenspalte mit bestimmten Inhalten zu ueberschreiben.
#'
#' Zu beachten ist hier, dass die entsprechenden Zellen einfach nur ueberschrieben werden und die Aufteilung von \code{tab1}
#' auf die Spalten der Excel-Tabelle in keiner Weise angepasst wird.
#' Sollte man ZUSAETZLICH zu \code{tab1} (und evt. auch zusaetzlich zu \code{inheritTemplateColNr}) eine neue Spalte hinzufuegen wollen
#' so sind die Parameter \code{customColNr} bzw. \code{customCol} anzuwenden.
#'
#' @param f_in File Name inklusive Pfad und File-Endungen des eingelesenen
#' Original-Excel-Files.
#' @param sheet Index oder Name des Excel-Sheets oder des zugehoerigen Template-Excel-Sheets.
#' @param prefixTSN Character: das Prefix des Namens des Template Sheets (siehe Details).
#' Default ist "_".
#' @param removeTemplateSheet TRUE/FALSE ob das Template-Excel-Sheet (mit dem Prefix \code{prefixTSN}) zum aktuell
#' bearbeiteten Excel-Sheet geloescht werden soll, also ob es nicht im ausgelesenen File enthalten sein soll.
#' @param removeAllTemplates TRUE/FALSE wie bei \code{removeTemplateSheet}, nur dass hier abgefragt wird,
#' ob ALLE Template-Excel-Sheets, also alle Sheets mit dem Prefix \code{prefixTSN},
#' geloescht werden sollen, also ob das ausgelesene File keine Templates mehr enthalten soll.
#' @param interactive Logical ob das Loeschen von Template-Sheets (\code{removeTemplateSheet},\code{removeAllTemplates})
#' erst manuell durch den Nutzer bestaetigt werden soll.
#' @param showFinalTab Logical: Falls TRUE, wird in R die Tabelle samt Leerzeilen ausgegeben wie
#' sie auch im ausgelesenen Excel-File landen wuerde. Ist dieser Parameter gesetzt, wird also kein Excel-File erstellt.
#' @param showSplitTab Logical: Falls TRUE, wird in R die durch \code{startingPoints} aufgesplittete Tabelle ausgegeben.
#' Ist dieser Parameter gesetzt, wird also kein Excel-File erstellt.
#' @return Output ist ein Excel-File.
#' @seealso
#' \code{\link{MakeTable},\link{MakeQT},\link{ImportData},\link{IndivImportData},\link{ImportDataListQT}}
#' @export
#' @examples
#' \dontrun{
#' ###
#' Kommt wahrscheinlich ins mitgelieferte Bsp-File - samt Excel-Rohling.
#' ###
#'
#' ### Beispiel einer customCellList:
#' # 1. die 1. Spalte der Tabelle soll ab der 1. Zeile der Tabelle die Eintraege
#' # Category 1, Category 2 und Category 3 haben mit einer Leerzeile nach Category 1
#' # 2. wir wollen nur eine einzelne Zelle ansprechen und dort die Fussnote einfuegen
#' # -> die 1. Spalte der Tabelle soll in Zeile 5 die Fussnote enthalten
#' customCellList=list(
#' list(row=1,col=1,entry=c("Category 1", NA, "Category 2","Category 3")),
#' list(row=5,col=1,entry="FussnoteBlaBlaText")
#' )
#' # bzw dasselbe in anderer Schreibweise:
#' customCellList <- list()
#' customCellList[[length(customCellList)+1]] <-
#' list(row=1,col=1,entry=c("Category 1", NA, "Category 2","Category 3"))
#' customCellList[[length(customCellList)+1]] <-
#' list(row=5,col=1,entry="FussnoteBlaBlaText")
#' }
#'
FillExcelTemplate <- function(tab1,tab2=NULL,startingPoints,nrEmptyRows,
inheritTemplateColNr=1,customColNr=NULL,customCol=NULL,customCellList=NULL,
f_in,sheet=1,prefixTSN="_",
removeTemplateSheet=FALSE,removeAllTemplates=FALSE,interactive=TRUE,
showFinalTab=FALSE,showSplitTab=FALSE){
if(!removeAllTemplates){
## Fehler abfangen
if(!file.exists(f_in)){
stop("\n\nFile '",f_in,"' existiert nicht und kann daher nicht eingelesen werden!\n")
}
if(!is.null(customCol) && is.null(customColNr)){
stop("\n\nZu customCol muss eine customColNr spezifiziert werden. Siehe Help-File!\n")
}
if(!is.null(inheritTemplateColNr) && !is.null(customCol)){
if(customColNr %in% inheritTemplateColNr){
stop("\n\ncustomColNr darf nicht gleich inheritTemplateColNr sein!\n")
}
}
if(!is.null(customCol)){
if(length(customCol)!=nrow(tab1)){
stop("\n\nDer Vektor customCol muss gleich viele Elemente haben wie tab1 Zeilen hat!\n")
}
if(length(customColNr)>1){
stop("\n\nDerzeit kann nur EINE customColNr spezifiziert werden!\n")
}
if(identical(customColNr,0)){
customCol <- NULL
customColNr <- NULL
}
}
if(!is.null(inheritTemplateColNr)){
if(any(inheritTemplateColNr>(ncol(tab1)+length(inheritTemplateColNr)+1))){
#bzw +length(customColNr) - falls wir das mal aendern
warning("\n\n\nACHTUNG: inheritTemplateColNr ",
paste0(inheritTemplateColNr[which(inheritTemplateColNr>(ncol(tab1)+length(inheritTemplateColNr)+1))],collapse=", "),
" ist zu gross (ausserhalb der Tabelle) und wird aus inheritTemplateColNr entfernt!!!!\n\n")
inheritTemplateColNr <- inheritTemplateColNr[-which(inheritTemplateColNr>(ncol(tab1)+length(inheritTemplateColNr)+1))]
if(length(inheritTemplateColNr)==0){
inheritTemplateColNr <- NULL
}
}
if(0%in%inheritTemplateColNr){
if(identical(customColNr,0)){
inheritTemplateColNr <- NULL
}else{
stop("inheritTemplateColNr enthaelt den Wert 0, das macht keinen Sinn :-( !\n")
}
}
}
tab1ColNr <- seq(1:(ncol(tab1)+length(inheritTemplateColNr)+length(customColNr)))
if(!is.null(inheritTemplateColNr) || !is.null(customColNr)){
tab1ColNr <- tab1ColNr[-c(inheritTemplateColNr,customColNr)]
}
## Leerzeilen zu tab1 und tab2 hinzufuegen
erg <- Tabelle_bearbeiten(tab1,startingPoints=startingPoints,nrEmptyRows=nrEmptyRows)
if(is.null(tab2)){
erg2 <- copy(erg)
}else{
erg2 <- Tabelle_bearbeiten(tab2,startingPoints=startingPoints,nrEmptyRows=nrEmptyRows)
}
if(showFinalTab){
return(erg)
}
######################################################################
## 3. Excel-File inklusive dort vorgegebener Formate einlesen ##
######################################################################
# Excel-File Einlesen
wb <- loadWorkbook(f_in, create=TRUE)
cat("\n",f_in," wird eingelesen.\n")
setStyleAction(wb,XLC$"STYLE_ACTION.NONE") #dadurch werden die vorgegebenen Formate beibehalten
sheets <- getSheets(wb)
# Helper Function: wollen sheet als number und nicht als character.
# Ausserdem wollen wir auf Nummer Sicher gehen, dass das von uns uebergebene sheet ueberhaupt existiert!
sheet_as_number <- function(sheets=sheets, sheet=sheet, prefixTSN=prefixTSN){
if(is.character(sheet)){
sheet.orig <- sheet
sheet <- which(sheets==sheet)
# falls nur _-sheet existiert, aber zu befuellender sheet-Name angegeben wurde und umgekehrt
if(length(sheet)==0 && !paste0(prefixTSN,sheet.orig)%in%sheets && !substr(sheet.orig,2,nchar(sheet.orig))%in%sheets){
stop("Excel-Sheet '",sheet.orig,"' kann nicht gefunden werden!")
}else if(length(sheet)==0 && paste0(prefixTSN,sheet.orig)%in%sheets){
sheet.orig <- sheet <- paste0(prefixTSN,sheet.orig)
sheet <- which(sheets==sheet)
}else if(length(sheet)==0 && substr(sheet.orig,2,nchar(sheet.orig))%in%sheets){
sheet.orig <- sheet <- substr(sheet.orig,2,nchar(sheet.orig))
sheet <- which(sheets==sheet)
}
}else{
sheet.orig <- sheets[sheet]
}
list(sheet=sheet, sheet.orig=sheet.orig)
}
sheet <- sheet_as_number(sheets=sheets, sheet=sheet, prefixTSN=prefixTSN)$sheet
sheet.orig <- sheet_as_number(sheets=sheets, sheet=sheet, prefixTSN=prefixTSN)$sheet.orig
# Falls zu befuellendes sheet schon existiert, sollten wir dieses loeschen und als kopie von _-sheet neu erstellen
# Ansonsten wird ja das Format (also evt. Klammern usw. vom frueher schon mal befuellten befuellten Sheet genommen)
if((existsSheet(wb,substr(sheets[sheet],2,nchar(sheets[sheet]))) && existsSheet(wb,sheets[sheet]))){
removeSheet(wb,substr(sheets[sheet],2,nchar(sheets[sheet])))
sheets <- getSheets(wb)
sheet <- sheet.orig
}else if(existsSheet(wb,paste0(prefixTSN,sheets[sheet])) && existsSheet(wb,sheets[sheet])){
removeSheet(wb,sheets[sheet])
sheets <- getSheets(wb)
sheet <- sheet.orig
}
# Wieder Zahl statt character fuer sheet und Kontrolle von uebergebenem sheet-Name
sheet <- sheet_as_number(sheets=sheets, sheet=sheet, prefixTSN=prefixTSN)$sheet
sheet.orig <- sheet_as_number(sheets=sheets, sheet=sheet, prefixTSN=prefixTSN)$sheet.orig
# leeres sheet generieren, falls es noch keines gibt
if(!existsSheet(wb,paste0(prefixTSN,sheets[sheet])) && substr(sheets[sheet],1,1)!=prefixTSN){
cloneSheet(wb,sheets[sheet],name=paste0(prefixTSN,sheets[sheet]))
sheets <- getSheets(wb)
}
# zu befuellendes sheet generieren falls es nur das leere gibt
if(substr(sheets[sheet],1,1)==prefixTSN && !existsSheet(wb,substr(sheets[sheet],2,nchar(sheets[sheet])))){
newsheetname <- substr(sheets[sheet],2,nchar(sheets[sheet]))
cloneSheet(wb,sheets[sheet],name=newsheetname)
sheets <- getSheets(wb)
sheet <- which(sheets==newsheetname)
}
# leeres _-sheet immer vor zu befuellendes sheet stellen (noch mal kontrollieren diesen Teil hier)
if(getSheetPos(wb,sheets[sheet]) != (getSheetPos(wb,paste0(prefixTSN,sheets[sheet]))+1)){
if(getSheetPos(wb,sheets[sheet]) < getSheetPos(wb,paste0(prefixTSN,sheets[sheet]))){
if(getSheetPos(wb,sheets[sheet])-1!=0)
setSheetPos(wb,paste0(prefixTSN,sheets[sheet]),getSheetPos(wb,sheets[sheet]))
else
setSheetPos(wb,paste0(prefixTSN,sheets[sheet]),1)
}else{
newPosition <- getSheetPos(wb,paste0(prefixTSN,sheets[sheet]))+1
setSheetPos(wb,sheets[sheet],newPosition)
sheet <- newPosition
}
sheets <- getSheets(wb)
}
# aktives Sheet soll das neu zu befuellende sein
if(substr(sheets[which(sheets==sheet.orig)],1,1)==prefixTSN){
if(substr(sheets[sheet],1,1)==prefixTSN){
newsheetname <- substr(sheets[sheet],2,nchar(sheets[sheet]))
sheet <- which(sheets==newsheetname)
}
setActiveSheet(wb,sheets[sheet])
}else{
sheet <- which(sheets==sheet.orig)
setActiveSheet(wb,sheets[sheet])
}
cat("\n",sheets[sheet], " wird bearbeitet.\n")
# save.erg <- copy(erg)
# save.erg2 <- copy(erg2)
if((!is.null(inheritTemplateColNr) && !any(inheritTemplateColNr==0)) || !is.null(customCol)){
prepare_out_dt <- function(dt,inheritTemplateColNr, customCol, tab1ColNr){
ncol_newdt <- length(c(inheritTemplateColNr, customColNr, tab1ColNr))
newdt <- data.table(matrix(nrow=nrow(dt),ncol=ncol_newdt))
#newdt[,(colnames(newdt)):=lapply(.SD, as.character),.SDcols=colnames(newdt)]
newdt[,tab1ColNr] <- data.table(dt)
if(!is.null(customCol) && identical(dt,erg)){
newdt[,customColNr] <- Tabelle_bearbeiten(customCol,startingPoints=startingPoints,nrEmptyRows=nrEmptyRows)
}
colnames(newdt) <- LETTERS[1:ncol(newdt)]
return(newdt)
}
erg <- prepare_out_dt(erg,inheritTemplateColNr,customCol,tab1ColNr)
erg2 <- prepare_out_dt(erg2,inheritTemplateColNr,customCol,tab1ColNr)
}else{
colnames(erg) <- LETTERS[1:ncol(erg)]
colnames(erg2) <- LETTERS[1:ncol(erg2)]
erg <- as.data.table(erg)
erg2 <- as.data.table(erg2)
}
# erg <- copy(save.erg)
# erg2 <- copy(save.erg2)
# Befuellte Zeilen aus erg heraussuchen
zeilen_mit_inhalt <- as.numeric(which(apply(erg,1,function(x)any(!is.na(x)))))
#zeilen_mit_inhalt <- as.numeric(which(apply(erg,1,function(x)all(!is.na(x)))))
outlist <- list()
i_orig <- i <- 1
while(i<=length(zeilen_mit_inhalt)){
while((zeilen_mit_inhalt[i]+1)%in%zeilen_mit_inhalt){
i <- i+1
}
outlist[[length(outlist)+1]] <- erg[zeilen_mit_inhalt[i_orig]:zeilen_mit_inhalt[i],]
i_orig <- i+1
i <- i+1
}
if(showSplitTab){
return(outlist)
}
outlist.orig <- outlist
# da Klammern und x-e in erg vorkommen, sind die Zellenwerte nicht numerisch. Das wollen wir wieder aendern.
# durch as.numeric kommt es bei Zellen mit Characterwerten zu Missings -> nicht beunruhigend, die befuellen wir spaeter
# Output hier ist uebrigens eine Liste mit data.table-Elementen
if(!is.null(customColNr)){
whichcols <- colnames(outlist[[1]])[-customColNr]
}else{
whichcols <- colnames(outlist[[1]])
}
outlist <- lapply(outlist, function(x){
if(nrow(x)>1){
x[ ,(whichcols):=lapply(.SD,function(y) suppressWarnings(as.numeric(y))), .SDcols=whichcols]
}else if(nrow(x)==1){
x[ ,(whichcols):=lapply(.SD,function(y) suppressWarnings(as.numeric(y))), .SDcols=whichcols]
}
})
# wir suchen die ausgeklammerten Zellenwerte usw.
ausgeklammertes <- apply(erg,2,function(x)grep("(",x,fixed=TRUE)) # alle, d.h. (Wert) und (x)
ausgeklammertes_x <- apply(erg,2,function(x)grep("(x)",x,fixed=TRUE)) # (x)
ausgeklammertes_stern <- apply(erg,2,function(x)grep("*",x,fixed=TRUE)) # (x)
zelle_leer <- apply(erg,2,function(x){which(is.na(x))[which(which(is.na(x))%in%zeilen_mit_inhalt)]})
wert_null <- apply(erg2,2,function(x)which(abs(x) < .Machine$double.eps)) # Zellenwert 0
notanumber <- apply(erg,2,function(x)grep("NaN",x,fixed=TRUE)) # NaN
#c(ausgeklammertes,ausgeklammertes_x,ausgeklammertes_stern,zelle_leer,wert_null,wert_null)
removeFlag <- function(x,colNr){
for(i in 1:length(colNr)){
if(length(x)>0){
x[[colNr[i]]] <- grep("kreizbirnbaumhollastaudn","bla")
}
}
return(x)
}
if(!is.null(customCol)){
# Spezielle Zellenmarkierungen sollen fuer customCol NICHT gelten. Entfernen also alle eventuell unabsichtlich auftretenden Markierungen.
ausgeklammertes <- removeFlag(ausgeklammertes,colNr=customColNr)
ausgeklammertes_x <- removeFlag(ausgeklammertes_x,colNr=customColNr)
ausgeklammertes_stern <- removeFlag(ausgeklammertes_stern,colNr=customColNr)
zelle_leer <- removeFlag(zelle_leer,colNr=customColNr)
wert_null <- removeFlag(wert_null,colNr=customColNr)
notanumber <- removeFlag(notanumber,colNr=customColNr)
}
if(!is.null(inheritTemplateColNr) && !any(inheritTemplateColNr==0)){
# Spezielle Zellenmarkierungen sollen fuer inheritTemplateColNr NICHT gelten. Entfernen also alle eventuell unabsichtlich auftretenden Markierungen.
ausgeklammertes <- removeFlag(ausgeklammertes,colNr=inheritTemplateColNr)
ausgeklammertes_x <- removeFlag(ausgeklammertes_x,colNr=inheritTemplateColNr)
ausgeklammertes_stern <- removeFlag(ausgeklammertes_stern,colNr=inheritTemplateColNr)
zelle_leer <- removeFlag(zelle_leer,colNr=inheritTemplateColNr)
wert_null <- removeFlag(wert_null,colNr=inheritTemplateColNr)
notanumber <- removeFlag(notanumber,colNr=inheritTemplateColNr)
}
writeColNr <- sort(c(tab1ColNr,customColNr))
for(i in 1:length(startingPoints)){
# sel_seq <- seqle(writeColNr)
# values <- sel_seq$values[which(sel_seq$lengths>1)]
# lengths <- sel_seq$lengths[which(sel_seq$lengths>1)]
for(j in writeColNr){
writeWorksheet (wb, outlist[[i]][,j,with=FALSE], sheet=sheets[sheet], startRow=startingPoints[i], startCol=j ,header=FALSE )
}
}
# Koennten ein Format setzen fuer ausgeklammerte Werte:
klammern <- createCellStyle(wb)
klammern_x <- createCellStyle(wb)
stern <- createCellStyle(wb)
kein_eintrag <- createCellStyle(wb)
#null_mit_klammern <- createCellStyle(wb)
strich_statt_null <- createCellStyle(wb)
#setDataFormat(klammern, format = "(#.##0,0);(-#.##0,0);@")# deutsches Excel -> macht das daraus:(#,##00);(-#,##00);@
setDataFormat(klammern, format = "(#,##0.0);(-#,##0.0);@")# englisches Excel
setDataFormat(klammern_x, format = "(x);(x)")
setDataFormat(stern, format = "#,##0.0\"*\"")
setDataFormat(kein_eintrag, format = "0.0") #Zellen ohne Eintrag sollen "." enthalten.
#setDataFormat(null_mit_klammern, format = "\"[\"0\"]\";\"[\"0\"]\"") #Zellen sollen Format [0] bekommen.
setDataFormat(strich_statt_null, format = "-;-")
# Jetzt zur Extrawurst fuer die ausgeklammerten Werte
ersteZeile <- 1
#-> Erste Zeile in Excel-Sheet ab der erg als gesamter Block (also inklusive der ersten Zeile mit NAs) eingefuegt wird.
# Das ist 1, weil wir auch alle noetigen Leerzeilen schon in erg hinzugefuegt haben.
### Hier machen wir aus den ausgeklammerten Werten erst mal wieder numerische Werte um formatC() darauf anzuwenden.
# Dann werden die fehlenden Zellen im workbook Zelle fuer Zelle befuellt
# Hier auch wieder nicht schrecken, wenn warnings wegen as.numeric ausgegeben werden.
# Die Missings die daruch entstehen sind hier auch egal.
if(length(ausgeklammertes)>0){
if(is.null(tab2)){
stop("\ntab2 muss angegeben werden da fuer tab1 ein Limit gesetzt wurde und gewisse Zellen keinen numerischen Wert enthalten!\n")
}
for( i in 1:length(ausgeklammertes)){
if(length(unlist(ausgeklammertes[i]))>0){
for(j in 1:length(unlist(ausgeklammertes[i]))){
wert.orig <- wert <- as.character(erg[suppressWarnings(as.numeric(unlist(ausgeklammertes[i])[j])),names(ausgeklammertes)[i],with=F])
wert <- gsub("(","",wert,fixed=TRUE)
wert <- gsub(")","",wert,fixed=TRUE)
if(!is.na(suppressWarnings(as.numeric(wert)))){
wert <- as.numeric(wert)
writeWorksheet (wb, wert, sheet=sheets[sheet], startRow=as.numeric(unlist(ausgeklammertes[i])[j])+(ersteZeile-1), startCol=grep(names(ausgeklammertes)[i],LETTERS) ,header=FALSE )
setCellStyle(wb, sheet=sheets[sheet], row=as.numeric(unlist(ausgeklammertes[i])[j])+(ersteZeile-1), col=grep(names(ausgeklammertes)[i],LETTERS), cellstyle=klammern)
}
}
}
}
}
if(length(ausgeklammertes_stern)>0){
if(is.null(tab2)){
stop("\ntab2 muss angegeben werden da fuer tab1 ein Limit gesetzt wurde und gewisse Zellen keinen numerischen Wert enthalten!\n")
}
for( i in 1:length(ausgeklammertes_stern)){
if(length(unlist(ausgeklammertes_stern[i]))>0){
for(j in 1:length(unlist(ausgeklammertes_stern[i]))){
wert.orig <- wert <- as.character(erg[suppressWarnings(as.numeric(unlist(ausgeklammertes_stern[i])[j])),names(ausgeklammertes_stern)[i],with=F])
wert <- gsub("*","",wert,fixed=TRUE)
if(!is.na(suppressWarnings(as.numeric(wert)))){
wert <- as.numeric(wert)
writeWorksheet (wb, wert, sheet=sheets[sheet], startRow=as.numeric(unlist(ausgeklammertes_stern[i])[j])+(ersteZeile-1), startCol=grep(names(ausgeklammertes_stern)[i],LETTERS) ,header=FALSE )
setCellStyle(wb, sheet=sheets[sheet], row=as.numeric(unlist(ausgeklammertes_stern[i])[j])+(ersteZeile-1), col=grep(names(ausgeklammertes_stern)[i],LETTERS), cellstyle=stern)
}
}
}
}
}
### (x) nur als label darueberlegen
if(length(ausgeklammertes_x)>0){
if(is.null(tab2)){
stop("\ntab2 muss angegeben werden da fuer tab1 ein Limit gesetzt wurde und gewisse Zellen keinen numerischen Wert enthalten!\n")
}
for( i in 1:length(ausgeklammertes_x)){
if(length(unlist(ausgeklammertes_x[i]))>0){
for(j in 1:length(unlist(ausgeklammertes_x[i]))){
wert <- as.numeric(erg2[suppressWarnings(as.numeric(unlist(ausgeklammertes_x[i])[j])),names(ausgeklammertes_x)[i],with=F])
writeWorksheet (wb, wert, sheet=sheets[sheet], startRow=as.numeric(unlist(ausgeklammertes_x[i])[j])+(ersteZeile-1), startCol=grep(names(ausgeklammertes_x)[i],LETTERS) ,header=FALSE )
setCellStyle(wb, sheet=sheets[sheet], row=as.numeric(unlist(ausgeklammertes_x[i])[j])+(ersteZeile-1), col=grep(names(ausgeklammertes_x)[i],LETTERS), cellstyle=klammern_x)
}
}
}
}
## Wert 0 soll in eckige Klammern kommen
if(length(wert_null)>0){
for( i in 1:length(wert_null)){
if(length(unlist(wert_null[i]))>0){
for(j in 1:length(unlist(wert_null[i]))){
wert <- 0
writeWorksheet (wb, wert, sheet=sheets[sheet], startRow=as.numeric(unlist(wert_null[i])[j])+(ersteZeile-1), startCol=grep(names(wert_null)[i],LETTERS) ,header=FALSE )
setCellStyle(wb, sheet=sheets[sheet], row=as.numeric(unlist(wert_null[i])[j])+(ersteZeile-1), col=grep(names(wert_null)[i],LETTERS), cellstyle=strich_statt_null)
}
}
}
}
## Statt NaN bzw leerer Zelle soll 0 in eckige Klammern kommen
if(length(notanumber)>0){
for( i in 1:length(notanumber)){
if(length(unlist(notanumber[i]))>0){
for(j in 1:length(unlist(notanumber[i]))){
wert <- 0 #Im Hintergrund soll 0 stehen?
writeWorksheet (wb, wert, sheet=sheets[sheet], startRow=as.numeric(unlist(notanumber[i])[j])+(ersteZeile-1), startCol=grep(names(notanumber)[i],LETTERS) ,header=FALSE )
setCellStyle(wb, sheet=sheets[sheet], row=as.numeric(unlist(notanumber[i])[j])+(ersteZeile-1), col=grep(names(notanumber)[i],LETTERS), cellstyle=strich_statt_null)
}
}
}
}
### Statt leerer Zelle soll ein Punkt angezeigt werden der aber als Zahl formatiert ist.
if(length(zelle_leer)>0){
for( i in 1:length(zelle_leer)){
if(length(unlist(zelle_leer[i]))>0){
for(j in 1:length(unlist(zelle_leer[i]))){
wert <- "."
writeWorksheet (wb, wert, sheet=sheets[sheet], startRow=as.numeric(unlist(zelle_leer[i])[j])+(ersteZeile-1), startCol=grep(names(zelle_leer)[i],LETTERS) ,header=FALSE )
setCellStyle(wb, sheet=sheets[sheet], row=as.numeric(unlist(zelle_leer[i])[j])+(ersteZeile-1), col=grep(names(zelle_leer)[i],LETTERS), cellstyle=kein_eintrag)
}
}
}
}
# ### Falls eine Fussnote eingefuegt werden soll
# if(!is.null(footnote)){
# writeWorksheet (wb, footnote, sheet=sheets[sheet], startRow=nrow(erg)+2, startCol=1 ,header=FALSE)
# }
### Falls einzelne Zellen individuell angepasst werden sollen
if(!is.null(customCellList)){
if(length(unlist(customCellList))<4){
stopifnot(all(names(customCellList)%in%c("row","col","entry")))
writeWorksheet (wb, customCellList[["entry"]], sheet=sheets[sheet], startRow=customCellList[["row"]], startCol=customCellList[["col"]] ,header=FALSE)
}else{
for(i in 1:length(customCellList)){
stopifnot(all(names(customCellList[[i]])%in%c("row","col","entry")))
writeWorksheet (wb, customCellList[[i]][["entry"]], sheet=sheets[sheet], startRow=customCellList[[i]][["row"]], startCol=customCellList[[i]][["col"]] ,header=FALSE)
}
}
}
if(removeTemplateSheet){
loeschen <- which(sheets==paste0(prefixTSN,sheets[sheet]))
if(interactive){
cat("\nSoll das Excel-Sheet ",sheets[loeschen], " wirklich geloescht werden?\n")
answer <- "a"
while(!tolower(answer)%in%c("nein","n","ja","j")){
answer <- readline(prompt="Bitte ja oder nein eingeben: \n")
if(tolower(answer)%in%c("nein","n"))
stop("\nLoeschen des Template-Excel-Sheets ",sheets[loeschen]," wird abgebrochen!\n",call.=FALSE)
else if(tolower(answer)%in%c("ja","j")){
answer2 <- "a"
while(!tolower(answer2)%in%c("nein","n","ja","j")){
answer2 <- readline(prompt="Soll vor dem Loeschen des Template-Sheets eine Sicherheitskopie des Files angelegt werden?: \n")
if(tolower(answer2)%in%c("ja","j")){
newfile <- unlist(strsplit(basename(f_in),".",fixed=TRUE))[length(unlist(strsplit(basename(f_in),".",fixed=TRUE)))-1]
fileExtension <- unlist(strsplit(basename(f_in),".",fixed=TRUE))[length(unlist(strsplit(basename(f_in),".",fixed=TRUE)))]
newfile <- paste0(dirname(f_in),"/",newfile,"_kopie.",fileExtension)
n <- 1
while(file.exists(newfile)){
newfile2 <- unlist(strsplit(basename(newfile),".",fixed=TRUE))[length(unlist(strsplit(basename(newfile),".",fixed=TRUE)))-1]
fileExtension <- unlist(strsplit(basename(newfile),".",fixed=TRUE))[length(unlist(strsplit(basename(newfile),".",fixed=TRUE)))]
newfile <- paste0(dirname(newfile),"/",newfile2,"_(",n,").",fileExtension)
n <- n+1
}
saveWorkbook(wb,file=newfile)
}
}
}
}
}
removeSheet(wb,sheet=loeschen)
}
}else{#ende not finalize file
cat("\n",f_in," wird eingelesen.\n")
# Excel-File Einlesen
wb <- loadWorkbook(f_in, create=TRUE)
setStyleAction(wb,XLC$"STYLE_ACTION.NONE") #dadurch werden die vorgegebenen Formate beibehalten
sheets <- getSheets(wb)
loeschen <- which(substr(sheets,1,1)==prefixTSN)
if(interactive){
cat("\nSollen die Template-Excel-Sheets ",sheets[loeschen], " wirklich geloescht werden?\n")
answer <- "a"
while(!tolower(answer)%in%c("nein","n","ja","j")){
answer <- readline(prompt="Bitte ja oder nein eingeben: \n")
if(tolower(answer)%in%c("nein","n"))
stop("\nLoeschen der Template-Excel-Sheets wird abgebrochen!\n",call.=FALSE)
else if(tolower(answer)%in%c("ja","j")){
answer2 <- "a"
while(!tolower(answer2)%in%c("nein","n","ja","j")){
answer2 <- readline(prompt="Soll vor dem Loeschen der Template-Sheets eine Sicherheitskopie des Original-Files angelegt werden?: \n")
if(tolower(answer2)%in%c("ja","j")){
newfile <- unlist(strsplit(basename(f_in),".",fixed=TRUE))[length(unlist(strsplit(basename(f_in),".",fixed=TRUE)))-1]
fileExtension <- unlist(strsplit(basename(f_in),".",fixed=TRUE))[length(unlist(strsplit(basename(f_in),".",fixed=TRUE)))]
newfile <- paste0(dirname(f_in),"/",newfile,"_kopie.",fileExtension)
n <- 1
while(file.exists(newfile)){
newfile2 <- unlist(strsplit(basename(newfile),".",fixed=TRUE))[length(unlist(strsplit(basename(newfile),".",fixed=TRUE)))-1]
fileExtension <- unlist(strsplit(basename(newfile),".",fixed=TRUE))[length(unlist(strsplit(basename(newfile),".",fixed=TRUE)))]
newfile <- paste0(dirname(newfile),"/",newfile2,"_(",n,").",fileExtension)
n <- n+1
}
saveWorkbook(wb,file=newfile)
}
}
}
}
}
loeschen <- loeschen-seq(0,length(loeschen)-1,by=1) ##removeSheet loescht nicht alle Spalten auf einmal die man angibt sondern iterativ, d.h. loeschen Spalte 3 bezieht sich nach dem Loeschen von Spalte 1 auf die urspruengliche Spalte 4.
removeSheet(wb,sheet=loeschen)
}
#removeSheet(wb,sheets[1])
saveWorkbook(wb,file=f_in)
cat("\n",f_in," wird wieder ausgelesen.\n")
cat("\n[fertig]\n")
cat("\n")
}