Comments (3)
We already have the code for cutf2
, we just need to remove the digit arguments, that will be dealt with by the formatting function.
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
}
from cutr.
Let's name all the functions cutf, cutf2, and cutf3 so we are more consistent ?
from cutr.
Done, digit argument was left as is to keep compatibility perfect, at the expense of potential flexibility
from cutr.
Related Issues (20)
- redesign arguments HOT 1
- wrong repo
- feature cutate HOT 1
- cut3 with "groups" warns about duplicate levels HOT 1
- hard cut HOT 3
- squeeze bugs with brackets = NULL HOT 1
- feature : membership HOT 2
- see package classInt HOT 1
- squeeze is bugged and needs more tests HOT 1
- open_end doc should be more clear HOT 1
- feature smart_bin HOT 1
- need to document new output and what features
- more tests for unsorted x!
- weighted cuts ?
- explicit what = "quantile" ?
- refactor code HOT 2
- be clearer about duplicate cut points
- not sure if set_mappers was so smart HOT 1
- group unfrequent values ?
Recommend Projects
-
React
A declarative, efficient, and flexible JavaScript library for building user interfaces.
-
Vue.js
🖖 Vue.js is a progressive, incrementally-adoptable JavaScript framework for building UI on the web.
-
Typescript
TypeScript is a superset of JavaScript that compiles to clean JavaScript output.
-
TensorFlow
An Open Source Machine Learning Framework for Everyone
-
Django
The Web framework for perfectionists with deadlines.
-
Laravel
A PHP framework for web artisans
-
D3
Bring data to life with SVG, Canvas and HTML. 📊📈🎉
-
Recommend Topics
-
javascript
JavaScript (JS) is a lightweight interpreted programming language with first-class functions.
-
web
Some thing interesting about web. New door for the world.
-
server
A server is a program made to process requests and deliver data to clients.
-
Machine learning
Machine learning is a way of modeling and interpreting data that allows a piece of software to respond intelligently.
-
Visualization
Some thing interesting about visualization, use data art
-
Game
Some thing interesting about game, make everyone happy.
Recommend Org
-
Facebook
We are working to build community through open source technology. NB: members must have two-factor auth.
-
Microsoft
Open source projects and samples from Microsoft.
-
Google
Google ❤️ Open Source for everyone.
-
Alibaba
Alibaba Open Source for everyone
-
D3
Data-Driven Documents codes.
-
Tencent
China tencent open source team.
from cutr.