/pkg/R/tableChange.R

  1#' Change a \link{tabplot-object}
  2#'
  3#' Change the order of columns, flip, and change the palettes of a \link{tabplot-object}.
  4#'
  5#' @aliases tableChange
  6#' @param tab \link{tabplot-object}
  7#' @param colNames vector of names of the desired columns
  8#' @param flip logical, if TRUE then the plot is flipped vertically, i.e.\ the row bins are reversed
  9#' @param pals list of color palettes. Each list item is on of the following:
 10#' \itemize{
 11#' \item a palette name in \code{\link{tablePalettes}}, optionally with the starting color between brackets.
 12#' \item a palette vector
 13#' }
 14#' @param colorNA color for missing values
 15#' @param numPals name(s) of the palette(s) that is(are) used for numeric variables ("Blues", "Greys", or "Greens"). Recycled if necessary.
 16#' @return \link{tabplot-object}
 17#' @export
 18#' @example ../examples/tableChange.R
 19
 20tableChange <- function(tab, colNames=sapply(tab$columns, function(col)col$name), flip=FALSE, pals=list(), colorNA = NULL, numPals = NULL) {
 21
 22	## change order of columns
 23	currentColNames <- sapply(tab$columns, function(col)col$name)
 24
 25	colID <- match(colNames, currentColNames)
 26	
 27	## check if each column in colNames exist in tab
 28	if (any(is.na(colID))) stop(paste("Column(s) ", paste(colNames[is.na(colID)], collapse=", "), " does(do) not exist."  , sep=""))
 29
 30	tab2 <- list(dataset=tab$dataset,
 31			n=length(colNames),
 32			nBins=tab$nBins,
 33			binSizes=tab$binSizes,
 34			isNumber=tab$isNumber[colID],
 35			rows=tab$rows,
 36			columns=lapply(colID, function(id) tab$column[[id]])
 37		)
 38
 39	## flip tabplot
 40	if (flip) {
 41		tab2$rows$heights <- rev(tab$rows$heights)
 42		
 43		tab2$rows$heights <- -(tab$binSizes/tab$rows$m)
 44	    tab2$rows$y <- 1- c(0,cumsum(tab$binSizes/tab$rows$m)[-tab$nBins])
 45	
 46		tab2$rows$marks <- rev(tab$rows$marks)
 47		
 48	
 49		flipCol <- function(col) {
 50			col$sort <- ifelse(col$sort=="", "", ifelse(col$sort=="decreasing", "increasing", "decreasing"))
 51			if (col$isnumeric) {
 52				col$mean <- rev(col$mean)
 53				col$compl <- rev(col$compl)
 54				col$lower <- rev(col$lower)
 55				col$upper <- rev(col$upper)
 56				col$mean.scaled <- rev(col$mean.scaled)
 57				col$mean.brokenX <- rev(col$mean.brokenX)
 58				col$widths <- rev(col$widths)
 59			} else {
 60				col$freq <- col$freq[nrow(col$freq):1,]		
 61				col$x <- col$x[nrow(col$x):1,]		
 62				col$widths <- col$widths[nrow(col$widths):1,]		
 63			}
 64			return(col)
 65		}
 66		
 67		tab2$columns <- lapply(tab2$columns, flipCol)
 68	}
 69	
 70	## change palettes
 71	if (length(pals)!=0) {
 72		pals <- tableplot_checkPals(pals)
 73
 74		whichCategorical <- which(sapply(tab2$columns, FUN=function(col)!col$isnumeric))
 75
 76		paletNr <- 1
 77		for (i in whichCategorical) {
 78			tab2$columns[[i]]$paletname <- pals$name[paletNr]
 79			tab2$columns[[i]]$palet <- pals$palette[[paletNr]]
 80			paletNr <- ifelse(paletNr==length(pals$name), 1, paletNr + 1)
 81		}
 82	}
 83
 84	## change colorNA
 85	if (!is.null(colorNA)) {
 86		## Check colorNA
 87		if (class(try(col2rgb(colorNA), silent=TRUE))=="try-error") {
 88			stop("<colorNA> is not correct")
 89		}
 90		whichCategorical <- which(sapply(tab2$columns, FUN=function(col)!col$isnumeric))
 91
 92		for (i in whichCategorical) {
 93			tab2$columns[[i]]$colorNA <- colorNA
 94		}
 95	}
 96	
 97	## change numeric palettes
 98	if (!is.null(numPals)) {
 99		## Check numPals
100		if ((class(numPals)!="character") || !all(numPals %in% c("Blues", "Greens", "Greys"))) stop("<numPals> is not correct")
101
102		whichNumeric <- which(sapply(tab2$columns, FUN=function(col)col$isnumeric))	
103		numPals <- rep(numPals, length.out=length(whichNumeric))
104		paletNr <- 1
105		for (i in whichNumeric) {
106			tab2$columns[[i]]$paletname <- numPals[paletNr]
107			paletNr <- paletNr + 1
108		}
109		
110	}
111	
112	class(tab2) <- "tabplot"
113	return(tab2)
114}