Parses a codebook file where lines starting at column zero (far left) represet variable information (e.g. name, description, type) and indented lines (i.e. lines beginning with white space, either tabs or spaces, etc.) represent factor levels and labels.

parse.codebook.r

#' Parse a codebook file with variable and level information.
#' 
#' Parses a codebook file where lines starting at column zero (far left) represet
#' variable information (e.g. name, description, type) and indented lines 
#' (i.e. lines beginning with white space, either tabs or spaces, etc.) represent factor
#' levels and labels. 
#' 
#' Note that white space at the beginning and end of each line is stripped before
#' processing that line.
#' 
#' This function will return a data frame with two additional 
#' 
#' @param file codebook file name.
#' @param var.names the name of the columns for variable rows.
#' @param level.names the name of the columns for level rows.
#' @param var.sep the separator for variable rows.
#' @param level.sep the separator for level rows.
#' @param level.indent character vector providing character(s) at the beginning
#'        of the line that indicate the line represents a factor level. Each
#'        element should have 1 character as only the first character of the line
#'        is compared.
#' @param var.name the name in \code{var.names} that represents the variable name.
#'        This should be a valid R variable name as this will be the column name
#'        in the corresponding data file, as well as the name used in the \code{list}
#'        of levels stored as an attribute to the returned object.
#' @param ... currently unused.
#' @return the codebook as a data frame with one attribute, \code{levels}, that
#'        is a list of data frames corresponding the levels and labels for each
#'        varaible. 
#' @author Jason Bryer <<jason@@bryer.org>>
#' @export
parse.codebook <- function(file, 
						   var.names, 
						   level.names,
						   level.indent=c(' ','\t'),
						   var.sep, 
						   level.sep, 
						   var.widths,
						   level.widths,
						   var.name = var.names[1],
						   ...) {
	stopifnot(var.name %in% var.names)
	
	stripWhite <- function(x) {
		sub('([[:space:]]+$)', '', sub("(^[[:space:]]+)", '', x, perl=TRUE), perl=TRUE)
	}
	
	codebook.raw <- readLines(file)
	
	#Remove blank lines
	blanklines <- which(nchar(stripWhite(codebook.raw)) == 0)
	linenums <- which(!(substr(codebook.raw, 1, 1) %in% level.indent))
	linenums <- linenums[!linenums %in% blanklines]
	linenums.levels <- which(substr(codebook.raw, 1, 1) %in% level.indent)
	linenums.levels <- linenums.levels[!linenums.levels %in% blanklines]
	if(length(blanklines) > 0) {
		codebook.raw <- codebook.raw[-blanklines]		
	}
	
	rows <- which(!(substr(codebook.raw, 1, 1) %in% level.indent))
	rows.levels <- which(substr(codebook.raw, 1, 1) %in% level.indent)
	rowmapping <- data.frame(pre=linenums, post=rows)
	rowmapping.levels <- data.frame(pre=linenums.levels, post=rows.levels)
	codebook <- codebook.raw[rows]
	
	if(!missing(var.sep)) { #Fields are delimited
		split <- strsplit(codebook, var.sep, fixed=TRUE)
		badrows <- codebook[sapply(split, length) != length(var.names)]
		if(length(badrows) > 0) {
			stop(paste("The following rows do not have ", length(var.names), 
					   " values: ", paste(badrows, collapse=', '), sep=''))
		}
		codebook <- as.data.frame(matrix(stripWhite( 
						unlist(strsplit(codebook, var.sep, fixed=TRUE))),
						ncol=length(var.names), byrow=TRUE, 
						dimnames=list(1:length(rows), var.names)), 
						stringsAsFactors=FALSE)
		codebook$linenum <- rows
	} else if(!missing(var.widths)) { #Fields are fixed with
		stopifnot(length(var.names) == length(var.widths))
		left <- 1
		cb <- data.frame(linenum=linenums)
		for(i in seq_along(var.widths)) {
			cb[,var.names[i]] <- sapply(
		    	codebook, FUN=function(x) {
		    		stripWhite(substr(x, left, min(nchar(x), (left + var.widths[i]))))
		    	})
			left <- left + var.widths[i]
		}
		codebook <- cb
		rm(cb)
	} else {
		stop("Must specify either var.sep or var.widths")
	}
	
	varsWithFactors <- which(sapply(1:(length(rows)-1), 
						FUN=function(x) { rows[x] + 1 != rows[x+1] }))
	varlevels <- list()
	for(i in seq_along(rows[varsWithFactors])) {
		start <- rows[varsWithFactors][i]
		end <- rows[which(rows == start) + 1]
		levels.raw <- codebook.raw[ (start + 1):(end - 1) ]
		if(!missing(level.widths)) { #Fixed with levels
			levels.raw <- lapply(levels.raw, FUN=function(x) {
				left <- 1
				lc <- character()
				for(i in seq_along(level.widths)) {
					lc <- c(lc, 
							substr(x, left, min(nchar(x), (left + level.widths[[i]])))
					)
					left <- left + level.widths[i]
				}
				return(lc)
			})
		} else if(!missing(level.sep)) { #Delimited levels
			levels.raw <- strsplit(sub('(^[[:space:]]+)', '', levels.raw, perl=TRUE), 
								   level.sep, fixed=TRUE)
		} else {
			stop('Must specify either level.sep or level.widths')
		}
		levels.df <- data.frame(linenum=rowmapping.levels[rowmapping.levels$post > start &
											   rowmapping.levels$post < end, 'pre'])
		for(i in seq_along(level.names)) {
			levels.df[,level.names[i]] <- sapply(levels.raw, FUN=function(x) { stripWhite(x[i]) })
		}
		var <- codebook[codebook$linenum == rowmapping[start == rowmapping$post,'pre'], var.name]
		varlevels[[var]] <- levels.df
	}
	
	codebook$isfactor <- codebook$var %in% names(varlevels)
	
	attr(codebook, 'levels') <- varlevels
	class(codebook) <- c('codebook', 'data.frame')
	return(codebook)
}