Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
# export from R to Excel with conditional highlighting
# see http://stackoverflow.com/questions/21618556/export-data-frames-to-excel-via-xlsx-with-conditional-formatting
#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
# get some data from the psych package
library(psych)
dat <- bfi
# load xlsx
library(xlsx)
# break up variables into scales to demonstrate looping
scales <- c("scale.a",
"scale.c",
"scale.e",
"scale.n",
"scale.o")
dat.scale.a <- dat[,1:5]
dat.scale.c <- dat[,6:10]
dat.scale.e <- dat[,11:15]
dat.scale.n <- dat[,16:20]
dat.scale.o <- dat[,21:25]
# run several EFAs
l <- 1 # needed for first run to create excel file
for (s in scales) {
# get items
input <- get(paste("dat", s, sep="."))
input <- input[complete.cases(input),]
# EFA
for (f in 1:2) { # extract 1 and 2 factors for demonstration
obl <- fa(input, nfactors=f, rotate="oblimin", fm="pa")
obl.df <- as.data.frame(unclass(obl$loadings))
# rename
assign(paste(s, f,"obl", sep="."), obl.df)
# output to excel
if (l==1) { # if first pass, create file
write.xlsx(obl.df, "mydata.xlsx",
sheetName=paste(s, f,"obl", sep="."))
# counter
l <- 0
} else # if not first pass, append
write.xlsx(obl.df, "mydata.xlsx",
sheetName=paste(s, f,"obl", sep="."),
append=TRUE)
}
remove(f)
remove(obl)
remove(obl.df)
}
remove(s)
remove(l)
# highlight loading values if abs(x) >= .3
file <- "mydata.xlsx" # define file object
wb <- loadWorkbook(file) # load workbook
fo <- Fill(foregroundColor="yellow") # create fill object
cs <- CellStyle(wb, fill=fo) # create cell style
sheets <- getSheets(wb) # get all sheets
# loop over sheets
for (sh in names(sheets)) {
sheet <- sheets[[sh]] # get specific sheet
cols <- length(get(sh))-1
rows <- getRows(sheet,
rowIndex=2:(nrow(get(sh))+1)) # get rows
cells <- getCells(rows, colIndex = 2:(cols+2)) # get cells
# change start column if loadings do not start in second column of excel
values <- lapply(cells, getCellValue) # extract the values
# find cells meeting conditional criteria
highlight <- "test"
for (i in names(values)) {
x <- as.numeric(values[i])
if (abs(x)>=.3 & !is.na(x)) {
highlight <- c(highlight, i)
}
}
highlight <- highlight[-1]
# apply style to cells that meet criteria
lapply(names(cells[highlight]),
function(ii)setCellStyle(cells[[ii]],cs))
}
# save
saveWorkbook(wb, file)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment