export from R to Excel with conditional highlighting.r

#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
# 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)