cutb and cut2b about cutr HOT 3 CLOSED

cutf2 <- function (x, cuts, m = 150, g, levels.mean = FALSE, levels.digits, 
    minmax = TRUE, oneval = TRUE, onlycuts = FALSE, ordered = FALSE, 
    format_fun = format, ...) 
{
    method <- 1
    x.unique <- sort(unique(c(x[!is.na(x)], if (!missing(cuts)) cuts)))
    min.dif <- min(diff(x.unique))/2
    min.dif.factor <- 1
    if (missing(levels.digits)) 
        levels.digits <- if (levels.mean) 
            5
        else 3
    oldopt <- options("levels.digits")
    options(levels.digits = levels.digits)
    on.exit(options(oldopt))
    xlab <- attr(x, "label")
    if (missing(cuts)) {
        nnm <- sum(!is.na(x))
        if (missing(g)) 
            g <- max(1, floor(nnm/m))
        if (g < 1) 
            stop("g must be >=1, m must be positive")
        options(digits = 15)
        n <- table(x)
        xx <- as.double(names(n))
        options(digits = levels.digits)
        cum <- cumsum(n)
        m <- length(xx)
        y <- as.integer(ifelse(is.na(x), NA, 1))
        labs <- character(g)
        cuts <- approx(cum, xx, xout = (1:g) * nnm/g, method = "constant", 
            rule = 2, f = 1)$y
        cuts[length(cuts)] <- max(xx)
        lower <- xx[1]
        upper <- 1e+45
        up <- low <- double(g)
        i <- 0
        for (j in 1:g) {
            cj <- if (method == 1 || j == 1) 
                cuts[j]
            else {
                if (i == 0) 
                  stop("program logic error")
                s <- if (is.na(lower)) 
                  FALSE
                else xx >= lower
                cum.used <- if (all(s)) 
                  0
                else max(cum[!s])
                if (j == m) 
                  max(xx)
                else if (sum(s) < 2) 
                  max(xx)
                else approx(cum[s] - cum.used, xx[s], xout = (nnm - 
                  cum.used)/(g - j + 1), method = "constant", 
                  rule = 2, f = 1)$y
            }
            if (cj == upper) 
                next
            i <- i + 1
            upper <- cj
            y[x >= (lower - min.dif.factor * min.dif)] <- i
            low[i] <- lower
            lower <- if (j == g) 
                upper
            else min(xx[xx > upper])
            if (is.na(lower)) 
                lower <- upper
            up[i] <- lower
        }
        low <- low[1:i]
        up <- up[1:i]
        variation <- logical(i)
        for (ii in 1:i) {
            r <- range(x[y == ii], na.rm = TRUE)
            variation[ii] <- diff(r) > 0
        }
        if (onlycuts) 
            return(unique(c(low, max(xx))))
        flow <- format_fun(low, ...)
        fup <- format_fun(up, ...)
        bb <- c(rep(")", i - 1), "]")
        labs <- ifelse(low == up | (oneval & !variation), flow, 
            paste("[", flow, ",", fup, bb, sep = ""))
        ss <- y == 0 & !is.na(y)
        if (any(ss)) 
            stop(paste("categorization error in cut2.  Values of x not appearing in any interval:\n", 
                paste(format(x[ss], digits = 12), collapse = " "), 
                "\nLower endpoints:", paste(format(low, digits = 12), 
                  collapse = " "), "\nUpper endpoints:", paste(format(up, 
                  digits = 12), collapse = " ")))
        y <- structure(y, class = "factor", levels = labs)
    }
    else {
        if (minmax) {
            r <- range(x, na.rm = TRUE)
            if (r[1] < cuts[1]) 
                cuts <- c(r[1], cuts)
            if (r[2] > max(cuts)) 
                cuts <- c(cuts, r[2])
        }
        l <- length(cuts)
        k2 <- cuts - min.dif
        k2[l] <- cuts[l]
        y <- cut(x, k2)
        if (!levels.mean) {
            brack <- rep(")", l - 1)
            brack[l - 1] <- "]"
            fmt <- format_fun(cuts, ...)
            labs <- paste("[", fmt[1:(l - 1)], ",", fmt[2:l], 
                brack, sep = "")
            if (oneval) {
                nu <- table(cut(x.unique, k2))
                if (length(nu) != length(levels(y))) 
                  stop("program logic error")
                levels(y) <- ifelse(nu == 1, c(fmt[1:(l - 2)], 
                  fmt[l]), labs)
            }
            else levels(y) <- labs
        }
    }
    if (levels.mean) {
        means <- tapply(x, y, function(w) mean(w, na.rm = TRUE))
        levels(y) <- format_fun(means, ...)
    }
    attr(y, "class") <- "factor"
    if (length(xlab)) 
        label(y) <- xlab
    if (ordered) 
        y <- factor(y, levels = lab)
    y
}