# ------------------------------------------------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------------------- # # # # File Name : NA and NULL handlers.r # # Last Updated Funclist : 10 Feb 2015, 5:09 PM (Tuesday) # # # # Author Name : Rick Saporta # # Author Email : RickSaporta@gmail.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : NA # # Packages Used via NS : NA # # # # ----------------------------------------------------------------------------------------------------------------------- # # # # is.NNNI ( x ) # # isNA ( x, null.as.NA=FALSE ) # # NAtoFALSE ( x ) # # whichOrNA ( x, ..., na.first=TRUE ) # # valueIfNull ( x, value ) # # locateFirstNA ( x ) # # locateFirstNonNA ( x, showWarnings=FALSE ) # # locateLastNonNA ( x, showWarnings=TRUE ) # # nonFiniteToNA ( x, replace=NA_real_ ) # # removeNA ( x, replace=NULL ) # # all_or_none_columnIsNA ( DT, col, by=NULL ) # # diffNA ( x, padTop=TRUE, fill=NA_integer_, scaled=FALSE, ... ) # # NA.unparsed ( NAs, default="logical", showWarnings=TRUE ) # # allNA_or_all0 ( x, tol=NULL, warnOnHighTol=TRUE ) # # is.naor0 ( x, tol=NULL, warnOnHighTol=TRUE ) # # howManyNAs ( x, returnPercentage=perc, perc=FALSE, hide.full=FALSE, sort=FALSE, ... ) # # howManyNAs.data.frame ( x, returnPercentage=perc, perc=FALSE, hide.full=TRUE, sort=FALSE ) # # howManyNAs.list ( x, returnPercentage=perc, perc=FALSE, hide.full=FALSE, sort=FALSE, ... ) # # howManyNAs.default ( x, returnPercentage=perc, perc=FALSE, hide.full=FALSE, ... ) # # NAsynonymClean_ ( DT, NAsynonyms, colsToClean=names(DT), verbose=FALSE ) # # # # # # # # ----------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------- # if (FALSE) { insertIntoFile_("/Users/rsaporta/git/misc/rscripts/utils/NA and NULL handlers.r") } equalOrNA <- function(x, y) { ## returns logical vector of only TRUE or FALSE's (no NAs) ## returns TRUE if pairwise x and y are equal or both NA ## returns FALSE if pairwise x and y are not equal or if only one of them are NA removeNA( (is.na(x) & is.na(y)) | (x == y) , replace = FALSE ) } locateLastFALSE_before_lastTRUE <- function(x, warn_on_staggered=TRUE, msg="x has staggered TRUE/FALSE values", warn_on_last_not_TRUE=FALSE) { ## This function is intended to find the last FALSE in a logical vector. ## Some vectors should be "smooth" all the way through, except for the end ## eg: such as when checking a time series has values greater than zero ## in which case, we can warn on those. if (!is.logical(x)) stop ("x should be logical") indicators <- diffNA(cumsum(x)) trues <- which (x) ## CHECK INPUT, and warn accordingly ....... ## ----------------------------------------------------- if (warn_on_last_not_TRUE) { if (length(x) %ni% trues) warning ("x does not end in TRUE") } if (warn_on_staggered) { if (any(diff(trues) > 1)) warning (msg) } ## ----------------------------------------------------- ## intepreting the length(trues) ## 0: means no TRUE, means all FALSE, so the last FALSE is the last x. Return the length(x) ## 1: means there is exactly one TRUE, and trues[[1]] is it's index; The max FALSE is right behind it. return (trues-1) ## length(x): means no FALSE, means all TRUE, so the last FALSE is non-existent, return 0L, meaning the index before the start ## else: Have to calculate the index. The diff(trues) will be 1 for any sequence of TRUES, and we use this information as described below if (length(trues) == 0) return(length(x)) if (length(trues) == 1) return(trues - 1) if (length(trues) == length(x)) return(0) ## If all of the TRUES are in a single sequence, return the index to the element right before the first one if (all(diff(trues) == 1)) return(trues[[1]] - 1) ## ELSE ## since not all elements are in a sequence, the last FALSE will be right before the last (sequence of) TRUEs ## So check the diffs, find the last (ie max) which is NOT 1; The sought-after last FALSE is right before it return( trues[ max(which(diffNA(trues) != 1)) ] - 1 ) } removeNullsFromList <- function(ll) { ll[!sapply(ll, is.null)] } removeNullsAndBlanksFromList <- function(ll) { ll[!sapply(ll, isNULLorBlank)] } nonFinitesToNA <- function(x, replacement=NA_real_) { nonFinites <- !is.finite(x) if (any(nonFinites)) x[nonFinites] <- replacement return(x) } is.NNNI <- function(x) is.null(x) || (is.na(x) | is.nan(x) | is.infinite(x)) # eg: # nonFiniteTestValues <- list(NULL, NA, NaN, Inf, -Inf, 0, 1, TRUE, FALSE, "hello", 7.5, 1e-6) # ret <- sapply(nonFiniteTestValues, is.NNNI) # setNames(ret, nonFiniteTestValues) isNA <- function(x, null.as.NA=FALSE) { # checks first for NULL, then for NA # avoids the logical(0) that results from is.na(NULL) if (is.null(x)) return (null.as.NA) is.na(x) } NAtoFALSE <- function(x) { x[is.na(x)] <- FALSE x } whichOrNA <- function(x, ..., na.first=TRUE) { # is TRUE or is NA # # TODO: Capture arr.ind, then use `rbind` if (na.first) c(which(is.na(x), ...), which(x, ...)) else c(which(x, ...), which(is.na(x), ...)) } ifelseNULL <- function(test, yes=NULL, no) { ## NON-VECTORIZED version of ifelse if (is.null(test)) yes else no } NULL_to_NA <- function(ll) { ## Used in Spotify Metadata JSON parsing lapply(ll, valueIfNull, NA) } valueIfNull <- function(x, value) { ## a wrapper to check if x is null and if so returns value if (is.null(x)) return(value) else return(x) } valueIfErr <- function(expr, value=NULL) { if (isErr(ret <- expr)) value else ret } valueIfErrOrNull <- function(expr, value) { valueIfNull( valueIfErr(expr, value) , value) } locateFirstNA <- function(x) { ## returns 0 if not any NA min(0, which(is.na(x))) } locateFirstNonNA <- function(x, showWarnings=FALSE) { ## returns 0 if not any NA if (all(is.na(x))) { verboseMsg(showWarnings, "All of x is NA. Returning length(x) + 1") return(length(x) + 1L) } min(which(!is.na(x))) } find_last_non_NA <- function(..., DEPRECATED = "use locateLastNonNA() instead") { warning("find_last_non_NA() has been deprecated -- use locateLastNonNA() instead") locateLastNonNA(...) } locateLastNonNA <- function(x, showWarnings=TRUE) { ## This function is useful for when x has a tail of NAs and ## we need to find the last element that is not an NA ## Note that NAs in the MIDDLE of x are disregarded ## ## x can be any object for which is.na(x) returns a logical vector. ## TEST CASES if (FALSE) { x <- 1:10; x[c(5, 9, 10)] <- NA; x; locateLastNonNA(x) x <- as.list(x); x; locateLastNonNA(x) x <- 1:10; x[c()] <- NA; x; locateLastNonNA(x) x <- 1:10; x[c(5, 9)] <- NA; x; locateLastNonNA(x) x <- 1:10; x[c(10)] <- NA; x; locateLastNonNA(x) x <- 1:10; x[] <- NA; x; locateLastNonNA(x) } ## Find the NAs NAs <- is.na(x) if (all(NAs)) { verboseMsg(showWarnings, "All of x is NA. Returning 0") return(0) } ## If the last element is NOT NA, then the last non-NA is length(x) ## Note this will be TRUE if (!any(is.na(x))) ie, if there are no NAs if (!NAs[[length(x)]]) return(length(x) ) ## ELSE # OLD: ## The cumsum of the REVERSE will increase until the first non-NA # OLD: ## diff(.) will identify the change # OLD: ## min(which) will find the first change. This will be off by one, but thats what we want # OLD: ## length(x) - {off by one} will identify the first non-NA # OLD: length(x) - min(which(diff(cumsum(rev(NAs))) == 0)) max(which(!NAs)) } nonFiniteToNA <- function(x, replace=NA_real_) { x[!is.finite(x)] <- replace x } removeNA <-function(x, replace=NULL, modify_levels_when_x_is_factor=FALSE, NA_first_or_last_level=c("last", "first"), showWarnings=TRUE) { ## quick wrapper for atomic x to drop NAs ## if (length(replace) > 1) stop("removeNA() is not vectorized. Use ifelse() instead.") missing.NA_first_or_last_level <- missing(NA_first_or_last_level) NA_first_or_last_level <- match.arg(NA_first_or_last_level, choices=c("last", "first"), several.ok=FALSE) if (NA_first_or_last_level == "first" && is.factor(x) && replace %ni% levels(x)) verboseMsg(showWarnings, "Setting NA_first_or_last_level to 'first' requires taking a hard copy of x") if (is.list(x)) { if (any(sapply(x, length) != 1)) return(lapply(x, removeNA, replace=replace)) } if (!length(x)) return(x) # if(!is.atomic(x)) # stop("`x` must be atomic") if (is.null(replace)) return(x[!is.na(x)]) # else ## FACTORS REQUIRE SPECIAL TREATMENT ## we cannot simply assign into a factor if 'replace' is not in the levels(x) ## This will put NAs right back ## Note that NAs in factors are rare. So Check for those before modifying if (is.factor(x)) { if (!any(is.na(x))) return(x) ## Now we know that there are NAs and we need to modify x ## ## If 'replace' is already a level in x, then there is no additional work needed ## However, if it is not, we need to modify the levels. If this is not flagged on, ## then we cannot modify x (since NAs will simply remain) if (replace %ni% levels(x)) { if (modify_levels_when_x_is_factor) { ## add the 'replace' value as a level, either to the front or back of the current set of levels if (NA_first_or_last_level == "last") setattr(x, "levels", c(levels(x), replace)) else x <- factor(x, levels=c(replace, levels(x))) } else { warning("x in removeNA(x, ..) is a factor and has NAs. However they cannot be replaced with '", replace, "' unless the levels(x) are modified. Returning x unchanged.\n\nHINT: set modify_levels_when_x_is_factor=TRUE ", call.=FALSE) return(x) } } } else { ## If not factor, this argument should not be used if (!missing.NA_first_or_last_level) warning("NA_first_or_last_level is ignored when x is not a factor") } ## Replace the NAs x[is.na(x)] <- replace x } all_or_none_columnIsNA <- function(DT, col, by=NULL) { DT[, {.vv <- is.na(get(col)); all(.vv) || !any(.vv)}, by=by][, all(V1)] } diffNA <- function(x, padTop=TRUE, fill=NA_integer_, scaled=FALSE, ...) { if (scaled && !padTop) { warning("You asked to scale AND you are padding from the bottom.\nAre you sure the results are what you expect?") } ## either take the straight diff or take the diff, scaled by the first value if (scaled) ret <- diff(x, ...) / x[-length(x)] else ret <- diff(x, ...) if (padTop) return(c(fill, ret)) else return(c(ret, fill)) } NA.unparsed <- function(NAs, default="logical", showWarnings=TRUE) { ## Returns a string version of NA, based on class of each element of NAs if (!length(NAs)) { if (showWarnings) warning ("Non-length vector 'NAs' passed to NA.unparsed()") return(NAs) } dict.NA.unparsed <- getDict("dict.NA.unparsed") classes <- sapply(NAs, class) if (!all({wr <- classes %in% names(dict.NA.unparsed)})) { warning("Some classes are not of known type") classes[!wr] <- default } ## Debugging # browser(expr=isErr(dict.NA.unparsed[classes]), text="in NA.unparsed - There is an error with [classes]") dict.NA.unparsed[classes] } # ------------------------------------------------------------------------ # allNA_or_all0 <- function(x, tol=NULL, warnOnHighTol=TRUE) { ## returns TRUE if x is either ALL 0 or ALL NA ## returns FALSE otherwise. Specifically, returns FALSE for a mix of NA and 0 ## ## If tol is NOT null, will use equals0(x) instead of x == 0 NAs <- is.na(x) if (all(NAs)) return(TRUE) else if (any(NAs)) return (FALSE) else if (!is.null(tol)) { if (abs(tol) > 1 && warnOnHighTol) warning ("Use set tol to large value. Did you mean to set it as an exponen, such as 1e-7 ?") return(all(equals0(x, tol=tol))) } else return(all(x == 0)) } is.naor0 <- function(x, tol=NULL, warnOnHighTol=TRUE) { ## Checks whether a value is NA or is zero ## If tol is NOT null, will use equals0(x) instead of x == 0 ## ## NOTE Difference between is.naor0() and allNA_or_all0() ## x <- c(0, NA, 0) ## is.naor0(x) == TRUE ## allNA_or_all0(x) == FALSE ## if (is.null(tol)) return(is.na(x) | (x == 0)) else { if (abs(tol) > 1 && warnOnHighTol) warning ("Use set tol to large value. Did you mean to set it as an exponen, such as 1e-7 ?") return (is.na(x) | equals0(x, tol=tol)) } } # ------------------------------------------------------------------------ # howManyNAs <- function(x, returnPercentage=perc, perc=FALSE, hide.full=FALSE, sort=FALSE, ...) { UseMethod("howManyNAs") } howManyNAs.data.frame <- function(x, returnPercentage=perc, perc=FALSE, hide.full=TRUE, sort=FALSE) { ## If there are no rows, we can't count how many are NA if (!nrow(x)) { warning("x has no rows. Returning NA") return(NA) } ret <- colSums(is.na(x)) if (hide.full) ret <- ret[ret != 0] if (returnPercentage) ret <- ret / nrow(x) if (sort) ret <- sort(ret) return(ret) } howManyNAs.list <- function(x, returnPercentage=perc, perc=FALSE, hide.full=FALSE, sort=FALSE, ...) { ## If there is no length, we can't count how many are NA if (!length(x)) { warning("x has no length. Returning NA") return(NA) } ret <- lapply(x, function(x1) howManyNAs(x1, returnPercentage=returnPercentage, hide.full=(hide.full && is.list(x1)), ...=...) ) if (sort) ret <- sort(ret) if (hide.full) ret <- ret[ret != 0] return(ret) } howManyNAs.default <- function(x, returnPercentage=perc, perc=FALSE, hide.full=FALSE, ...) { ## If there is no length, we can't count how many are NA if (!length(x)) { warning("x has no length. Returning NA") return(NA) } ret <- sum(is.na(x)) if (hide.full) ret <- ret[ret != 0] if (returnPercentage) ret <- ret / length(x) return(ret) } # ----------------------------------------------------------------------------------- # NAsynonymClean_ <- function(DT, NAsynonyms, colsToClean=names(DT), verbose=FALSE) { # For when there are synonyms for NA in the data # replacing in NAs requires an extra step. if (!is.data.table(DT)) stop("DT is not a data.table") nr <- nrow(DT) for (col in colsToClean) { inds <- DT[[col]] %in% NAsynonyms if (any(inds)) { if (verbose) cat("Cleaning ", sum(inds), "/", nr, " elements in ", col, "\n", sep="") if (is.factor(DT[[col]])) DT[, col := factor(col, levels=setdiff(levels(col), NAsynonyms))] else DT[inds, (col) := as(NA, Class=class(.SD[[1]])), .SDcols=col] } else if (Verbose) cat(sprintf("%12s is free of NAs", col), "\n") } } # ----------------------------------------------------------------------------------- # confirm_no_NAs_introduced <- function(x, tmp_NAs.original=is.na(x), tmp_NAs.new=is.na(as.num.nowarn(x)), colsToIgnore=setdiff(colnames(tmp_NAs.new), colnames(tmp_NAs.original)), verbose=TRUE) { ## Checks is.na(x) against tmp_NAs.original ## returns TRUE if NO NAs introduced ## FALSE if any NAs were introduced ## Thus this can be wrapped in ## stopifnot(confirm_no_NAs_introduced(x, tmp_NAs)) stop("this function is a clusterfuck") warning("Jan 2016 - Rick changed tmp_NAs.original and tmp_NAs.new --- if this was wraped in something, check what is calling this. May have broken ") nm.x <- capture.output(substitute(x)) verboseMsg(verbose, "Checking that no NAs were introduced into ", nm.x, " - ignoring columns: ", warningCols(midbreak="", columns=colsToIgnore)) if (length(colsToIgnore)) { tmp_NAs.original <- tmp_NAs.original[, !(colnames(tmp_NAs.original) %in% colsToIgnore)] tmp_NAs.new <- tmp_NAs.new[, !(colnames(tmp_NAs.new) %in% colsToIgnore)] } if (!identical(dim(tmp_NAs.new), dim(tmp_NAs.original))) { warning ("dims are different for the tmp_NAs. Cannot proceed -- returning FALSE", call.=FALSE) return(FALSE) } ## 2016-Jan Introduced this line tmp_NAs <- tmp_NAs.original if (any(wh.not <- tmp_NAs != tmp_NAs.new)) { if (verbose) { DT.NAs_introduced <- as.data.table(which(wh.not, arr.ind=TRUE)) if (!is.null(colnames(tmp_NAs))) DT.NAs_introduced[, Column := colnames(tmp_NAs)[col]] else DT.NAs_introduced[, Column := NA_character_] cat ("NAs were introduced into ", nm.x, " in the following columns\n") print(DT.NAs_introduced[, list(` Number of NAs introduced` = .N), keyby=list(`Column Number`=col, Column)]) } return(FALSE) } ## Otherwise, no NAs introduced. return(TRUE) }