# TODO: Add comment # # Author: E.Korsching Nov 25, 2013, 2022 ############################################################################### # bin() , bin.pointer() bin <- function(x, int=F, miss=F, x.range=NULL, bin.num=NULL, bin.size=NULL, bin.fix=NULL, fix.open=F){ # count values in a defined bin scheme # numeric values assumed - special mode for integer - not for character variables # bin scheme: first bin: x >= bin-bottom & x <= bin /all other/ x > bin & x <= bin-top # see also bin.open # x: vector of values (observations) # int: integer mode: F: like reals, T: every integer a category # miss: missing: F: no missing values, T: show missing values # x.range: NULL: calculate the range of x from data # else: c(min,max): set another range (larger [if information] or smaller than raw data) # ONLY one procedure at a time, the others NULL: bin.num, bin.size, bin.fix # bin.num: bin number scale of # bin.size: advance by x-value ranges # process starts from the smallest number # bin.fix: custom bin.size: define custom size units by a vector with breaks, # which is resulting in breaks-1 bins, e.g. c(50,200,1000, ...), [50-200], ]200-1000], ... # fix.open: T: all values outside the range will go in the first and last bin # F: all values outside the range will be discarded #ini if(mode(x)=="character"){ stop("\n stop - integers or real numbers assumed \n") } f1 <- function(erg){ for(i in 1:bin.num){ # counting of elements in bin range if(i==1){ tmp <- x >= min.x & x <= (min.x+step.size) # first step include top+bottom limits erg[i,1] <- sum(tmp, na.rm=T) erg[i,2] <- min.x erg[i,3] <- (min.x+step.size) }else if(i>1 & i ((i-1)*step.size + min.x) & x <= (i*step.size + min.x) erg[i,1] <- sum(tmp, na.rm=T) erg[i,2] <- ((i-1)*step.size + min.x) erg[i,3] <- (i*step.size + min.x) }else{ # i==bin.num tmp <- x > ((i-1)*step.size + min.x) & x <= max.x erg[i,1] <- sum(tmp, na.rm=T) erg[i,2] <- ((i-1)*step.size + min.x) erg[i,3] <- max.x } } return(erg) } f2 <- function(erg){ x.uni <- sort(unique(x)) if(miss){ erg <- matrix(0,(diff.x+1),3) dimnames(erg)[[2]] <- c("counts","start","end") # start end count levels k <- 1 for(i in min.x:max.x){ erg[k,1] <- sum(x==i, na.rm=T) erg[k,2] <- i erg[k,3] <- 0 k <-k+1 } }else{ xlu <- length(x.uni) erg <- matrix(0,xlu,3) dimnames(erg)[[2]] <- c("counts","start","end") # start end count levels for(i in 1:xlu){ erg[i,1] <- sum(x==x.uni[i], na.rm=T) erg[i,2] <- x.uni[i] erg[i,3] <- 0 } } return(list(erg=erg, bin.num=bin.num)) } # if(is.null(x.range)){ min.x <- min(x, na.rm=T) max.x <- max(x, na.rm=T) }else{ min.x <- x.range[1] max.x <- x.range[2] x <- x[x>=min.x & x<=max.x] } # In max.x - min.x : NAs produced by integer overflow (ok > integer.max) -- see qrng.R line 159 -- solved: integer, integer, class(diff.x) numeric test <- max.x-min.x # warning here but ok if(is.na(test)){ diff.x <- as.numeric(max.x)-as.numeric(min.x) }else{ diff.x <- max.x-min.x } # as.numeric() imprecision -> stepsize if(int){ if(!is.integer(x)){ stop("x needs to be integer for int=T") } step.size <- 1 erg <- f2() return(list(erg=erg$erg, para=c(bin.n=erg$bin.num, min=min.x, max=max.x, range.eff=diff.x+1, na=sum(is.na(x))), step.size=step.size)) } if(!is.null(bin.num)){ step.size <- diff.x/bin.num erg <- matrix(0,bin.num,3) dimnames(erg)[[2]] <- c("counts","start","end") # start end count levels erg <- f1(erg) return(list(erg=erg, para=c(bin.n=bin.num, min=min.x, max=max.x, range.eff=diff.x, na=sum(is.na(x))), step.size=step.size)) } if(!is.null(bin.size)){ step.size <- bin.size bin.num <- ceiling(diff.x/bin.size) # ev. beyond max.x erg <- matrix(0,bin.num,3) dimnames(erg)[[2]] <- c("counts","start","end") # start end count levels erg <- f1(erg) return(list(erg=erg, para=c(bin.n=bin.num, min=min.x, max=max.x, range.eff=diff.x, na=sum(is.na(x))), step.size=step.size)) } if(!is.null(bin.fix)){ bin.num <- length(bin.fix)-1 step.size <- bin.fix[2:(bin.num+1)]-bin.fix[1:bin.num] erg <- matrix(0,bin.num,3) dimnames(erg)[[2]] <- c("counts","start","end") # start end count levels if(fix.open){ for(i in 1:bin.num){ if(i==1){ tmp <- x <= bin.fix[(i+1)] erg[i,1] <- sum(tmp, na.rm=T) # bottom, open erg[i,2] <- -Inf erg[i,3] <- bin.fix[(i+1)] }else if(i>1 & i bin.fix[i] & x <= bin.fix[(i+1)] erg[i,1] <- sum(tmp, na.rm=T) # in-between erg[i,2] <- bin.fix[i] erg[i,3] <- bin.fix[(i+1)] }else{ # i==bin.num tmp <- x > bin.fix[i] erg[i,1] <- sum(tmp, na.rm=T) # top, open erg[i,2] <- bin.fix[i] erg[i,3] <- Inf } } }else{ for(i in 1:bin.num){ if(i==1){ tmp <- x >= bin.fix[i] & x <= bin.fix[(i+1)] erg[i,1] <- sum(tmp, na.rm=T) # bottom, limit erg[i,2] <- bin.fix[i] erg[i,3] <- bin.fix[(i+1)] }else if(i>1){ tmp <- x > bin.fix[i] & x <= bin.fix[(i+1)] erg[i,1] <- sum(tmp, na.rm=T) # in-between and top, limit erg[i,2] <- bin.fix[i] erg[i,3] <- bin.fix[(i+1)] } } } bf <- range(bin.fix) return(list(erg=erg, para=c(bin.n=bin.num, min=min.x, max=max.x, range.eff=diff.x, na=sum(is.na(x)), fix.start=bf[1], fix.end=bf[2], fix.open=fix.open), step.size=step.size)) } } # a1 <- rnorm(n=1000,mean=1,sd=1); range(a1) # a1 <- c(1,3,4,5,6,9); a1 <- c(1,2,3,4,5,6,9) # a <- bin(a1, x.range=NULL, bin.num=2, bin.size=NULL, bin.fix=NULL, fix.open=F) #bin(x=as.integer(c(10,4,7,3,7,4,9,3,5,3)), int=T, miss=F, x.range=c(4,10)) bin.pointer <- function(x, x.range=NULL, bin.num=NULL, bin.size=NULL, bin.fix=NULL, fix.open=F){ # Assign to each position in the x raw vector a bin (number) label -- so a pointer x[i] -> a[i] =bin number j # bin are sorted from small to large numbers # bin scheme like bin() # x: vector of values (observations) # x.range: NULL: calculate the range of x from data # else: c(min,max): set another range (larger [if information] or smaller than raw data) # ONLY one procedure at a time, the others NULL: bin.num, bin.size, bin.fix # bin.num: bin number scale of # bin.size: advance by x-value ranges # process starts from the smallest number # bin.fix: custom bin.size: define custom size units by a vector with breaks, # which is resulting in breaks-1 bins, e.g. c(50,200,1000, ...), bin.size[50-200],bin.size[200-1000], ... # fix.open: T: all values outside the range will go in the first and last bin # F: all values outside the range will be discarded #ini if(mode(x)=="character"){ stop("\n stop - real values assumed \n") } f1 <- function(erg){ for(i in 1:bin.num){ # counting of elements in bin range if(i==1){ erg[ x >= min.x & x <= (min.x+step.size) ] <- i #first step include both limits ! }else if(i>1 & i ((i-1)*step.size + min.x) & x <= (i*step.size + min.x) ] <- i }else{ # i==bin.num erg[ x > ((i-1)*step.size + min.x) & x <= max.x ] <- i } } return(erg) } # nr <- length(x) erg <- vector(mode="numeric",length=nr) # bin.pointer (x index of bin) if(is.null(x.range)){ min.x <- min(x, na.rm=TRUE) max.x <- max(x, na.rm=TRUE) }else{ min.x <- x.range[1] max.x <- x.range[2] } # In max.x - min.x : NAs produced by integer overflow (ok > integer.max) -- see qrng.R line 220 -- solved: integer, integer, class(diff.x) numeric test <- max.x-min.x if(is.na(test)){ diff.x <- as.numeric(max.x)-as.numeric(min.x) }else{ diff.x <- max.x-min.x } # as.numeric() imprecision -> stepsize if(!is.null(bin.num)){ step.size <- diff.x/bin.num erg <- f1(erg) return(erg) } if(!is.null(bin.size)){ step.size <- bin.size bin.num <- ceiling(diff.x/bin.size) # ev. beyond max.x erg <- f1(erg) return(erg) } if(!is.null(bin.fix)){ bin.num <- length(bin.fix)-1 step.size <- bin.fix[2:(bin.num+1)]-bin.fix[1:bin.num] if(fix.open){ for(i in 1:bin.num){ if(i==1){ erg[ x <= bin.fix[(i+1)] ] <- i # bottom, open }else if(i>1 & i bin.fix[i] & x <= bin.fix[(i+1)] ] <- i # in-between }else{ # i==bin.num erg[ x > bin.fix[i] ] <- i # top, open } } }else{ for(i in 1:bin.num){ if(i==1){ erg[ x >= bin.fix[i] & x <= bin.fix[(i+1)] ] <- i # bottom, limit }else if(i>1){ erg[ x > bin.fix[i] & x <= bin.fix[(i+1)] ] <- i # in-between and top, limit } } } return(erg) } } #a <- runif(20,0,1) #bin.pointer(x=a, x.range=NULL, bin.num=10, bin.size=NULL, bin.fix=NULL, fix.open=F) #a