R/hefner.a.r

In jjlynch2/AnthroStats: Anthropology Statistics

#' Ancestry estimation following Hefner and Ousley 2009
#' 
#' @param ANS 
#' @param INA 
#' @param IOB
#' @param NAW
#' @param NBS
#' @param PBD
#'
#' @keywords hefner.a
#' @export
#' hefner.a()

hefner.a <- function(X = NULL, methods = "all", research = FALSE) {
	
	if(length(methods) == 1 && methods[1] == "all") {
		methods <- c("OSSA", "DecTree")
	}
	clength <- length(methods)
	results <- data.frame(matrix(NA, ncol=(1 + (clength*4)), nrow=nrow(X))) #results data.frame

	for(i in 1:nrow(X)) {
		temp <- X[i,]
			
		if(temp$ANS >= 2) ANSO <- 1
		else ANSO <- 0

		if(temp$INA >= 4) INAO <- 1
		else INAO <- 0

		if(temp$IOB <= 2) IOBO <- 1
		else IOBO <- 0

		if(temp$NAW <= 2) NAWO <- 1
		else NAWO <- 0

		if(temp$NBS >= 2) NBSO <- 1
		else NBSO <- 0

		if(temp$PBD < 1) PBDO <- 1
		else PBDO <- 0

		OSSAR <- "Indeterminate"
		if(!all(is.na(ANSO), is.na(INAO), is.na(IOBO), is.na(NAWO), is.na(NBSO), is.na(PBDO))) {
			OSSA <- ANSO + INAO + IOBO + NAWO + NBSO + PBDO
			if(OSSA >= 4) OSSAR <- "White"
			else OSSAR <- "Black"
		}
		else { #used to see if 4+ exists even with missing scores
			OSSA <- ANSO + INAO + IOBO + NAWO + NBSO + PBDO
			if(OSSA >= 4) OSSAR <- "White"
		}

		atree <- "Indeterminate"
		if(!is.na(temp$INA)) {
			if(temp$INA < 1.5) { atree <- "Black"; n <- 96 / (96+9+3)}
			if(temp$INA >= 1.5) {
				if(!is.na(temp$NAW)) {
					if(temp$NAW < 1.5) { atree <- "White"; n <- 77 / (77+20+3)}
					if(temp$NAW >= 1.5) {
						if(INA >= 3.5) {
							if(!is.na(temp$IOB)) {
								if(temp$IOB >= 2.5) {atree <- "Black"; n <- 12 / (12+1+3) }
								if(temp$IOB < 2.5) {atree <- "White"; n <- 30 / (30+3+6)}
							}
						}
						if(temp$INA < 3.5) {
							if(temp$ANS < 1.5) {
								if(!is.na(temp$IOB)) {
									if(temp$IOB < 1.5) {atree <- "White"; n <- 9 / (9+1+0)}
									if(temp$IOB >= 1.5) {
										if(temp$NBS < 2.5) {atree <- "Black"; n <- 14 / (14+3+2)}
										if(temp$NBS >= 2.5) {atree <- "White"; n <- 6 / (6+1+2)}
									}
								}
							}
							if(temp$ANS >= 1.5) {
								if(temp$INA <= 2.5) {atree <- "Hispanic"; n <- 47 / (47+3+6)}
								if(temp$INA > 2.5) {
									if(!is.na(temp$IOB)) {
										if(temp$IOB < 1.5) {atree <- "Hispanic"; n <- 6 / (6+5+1)}
										if(temp$IOB >= 1.5) {atree <- "Black"; n <- 14 / (14+6+0)}
									}
								}
							}
				
						}
					}
				}
			}
		}


		pc <- 0
		spc <- 0

		if(OSSAR == "White") {pc <- 85.3}
		if(OSSAR == "Black") {pc <- 86.6}
		if(OSSA == 0) {spc <- 20 / 20}
		if(OSSA == 1) {spc <- 57 / 58}
		if(OSSA == 2) {spc <- 36 / 42}
		if(OSSA == 3) {spc <- 29 / 39}
		if(OSSA == 4) {spc <- 31 / 48}
		if(OSSA == 5) {spc <- 45 / 48}
		if(OSSA == 6) {spc <- 23 / 25}

		print(paste("OSSA: ", OSSAR, " Sample % correct: ", pc, " Score % correct: ", spc*100))
		print(paste("Decision Tree: ", atree, " End node: ", round(n*100, digits=2)))
	}#End for loop

}