/pkg/R/tableplot_checkPals.R

 1#' Function to check the tableplot argument: pals
 2#'
 3#' @aliases tableplot_checkPals
 4#' @param pals pals
 5#' @return object with palette information
 6#' @export 
 7tableplot_checkPals <- function(pals) {
 8
 9	if (class(pals)!="list") stop("<pals> is not a list")
10
11	#tabplotPalettes <- NULL; rm(tabplotPalettes); #trick R CMD check
12	#data("tabplotPalettes")
13	
14	palNames <- names(tabplotPalettes$qual)
15	palLengths <- nchar(palNames)
16	
17	getPal <- function(palName, startCol=1) {
18		originalPal <- tabplotPalettes$qual[[palName]]
19		pal <- originalPal[startCol:length(originalPal)]
20		if (startCol!=1) pal <- c(pal, originalPal[1:(startCol-1)])
21		palList <- list(palette=pal, name=paste(palName, "(", startCol, ")", sep=""))
22		return(palList)
23	}
24
25	
26	palList <- lapply(pals, FUN=function(x, palN, palL){
27		if (class(x)=="character" && length(x)==1) {
28			checkPals <- mapply(palN, palL, FUN=function(palN, palL, x)substr(x, 1, palL)==palN, MoreArgs=list(x))
29			if (sum(checkPals)==1) {
30				whichPal <- which(checkPals)
31				maxCol <- length(tabplotPalettes$qual[[whichPal]])
32				startCol <- as.integer(substr(x, palL[whichPal]+2, nchar(x)-1))
33				if (is.na(startCol) || startCol<1 || startCol>maxCol) startCol <- 1
34				return(getPal(palN[whichPal], startCol))
35			}
36		}
37	
38		if (class(try(col2rgb(x), silent=TRUE))=="try-error") {
39			stop("<pals> color palette(s) are not correct")
40		}
41		return(list(palette=x, name="custom"))
42		
43	}, palNames, palLengths)
44	
45	palN <- sapply(palList, FUN=function(x)x$name)
46	palP <- lapply(palList, FUN=function(x)x$palette)
47	
48	return(list(name=palN, palette=palP))
49}