背景
经过有用的讨论，以及我从 SO 同事那里获得的以下方面的帮助：
我结合了一个便利功能。这需要一个数字向量并生成与组有关的分解向量。
功能
该函数的主体如下所示。
nice.cuts <- function(variable, cuts = 10, thousands.separator = FALSE) {
# Load required packages (useful when used independently of context)
Vectorize(require)(package = c("gsubfn", "Hmisc", "scales"),
character.only = TRUE)
# Destring this variable
destring <- function(x) {
## convert factor to strings
if (is.character(x)) {
as.numeric(x)
} else if (is.factor(x)) {
as.numeric(levels(x))[x]
} else if (is.numeric(x)) {
x
} else {
stop("could not convert to numeric")
}
}
# Apply function
variable <- destring(variable)
# Check whether to disable scientific notation
if (mean(variable) > 100000) {
options(scipen = 999)
} else {
options(scipen = 0)
}
# Create pretty breaks
cut_breaks <- pretty_breaks(n = cuts)(variable)
# Round it two decimal places
variable <- round(variable, digits = 2)
# Develop cuts according to the provided object
cuts_variable <- cut2(x = variable, cuts = cut_breaks)
# Check if variable is total or with decimals
if (all(cut_breaks %% 1 == 0)) {
# Variable is integer
clean_cuts <- gsubfn('\\[\\s*(\\d+),\\s*(\\d+)[^0-9]+',
~paste0(x, '-',as.numeric(y)-1),
as.character(cuts_variable))
} else {
# Variable is not integer
# Create clean cuts
clean_cuts <- gsubfn('\\[\\s*([0-9]+\\.*[0-9]*),\\s*(\\d+\\.\\d+).*',
~paste0(x, '-', as.numeric(y)- 0.01),
as.character(cuts_variable))
}
# Clean Inf
clean_cuts <- gsub("Inf", max(variable), clean_cuts)
# Clean punctuation
clean_cuts <- sub("\\[(.*), (.*)\\]", "\\1 - \\2", clean_cuts)
# Replace strings with spaces
clean_cuts <- gsub("-"," - ",clean_cuts, fixed = TRUE)
# Trim white spaces
clean_cuts <- trimws(clean_cuts)
# Order factor before returning
clean_cuts <- factor(clean_cuts, levels = unique(clean_cuts[order(variable)]))
if (thousands.separator == TRUE) {
levels(clean_cuts) <- sapply(strsplit(levels(clean_cuts), " - "),
function(x) paste(prettyNum(x,
big.mark = ",",
preserve.width = "none"),
collapse = " - "))
}
# Return
return(clean_cuts)
}
结果
该函数在生成用于映射的因子时非常有用。例如对于以下值：
set.seed(1)
dta <- data.frame(values=floor(runif(100, 10000,90000)))
该功能将产生漂亮的休息
> dta$cuts <- nice.cuts(dta$values, thousands.separator = TRUE)
> t(t(table(dta$cuts))) #' t() for presentation
[,1]
10,000 - 19,999 9
20,000 - 29,999 11
30,000 - 39,999 12
40,000 - 49,999 20
50,000 - 59,999 6
60,000 - 69,999 15
70,000 - 79,999 17
80,000 - 89,999 10
可用于生成惊人的传说：
这在为等值线图生成数据时非常有用，我一直都在使用它。
问题
挑战与性能不佳有关。该功能似乎很慢。
非常小的数据集
对于包含100 个观测值的小型数据集，性能并不惊人：
> require(microbenchmark)
> dta <- data.frame(values=floor(runif(100, 10000,90000)))
> microbenchmark(nice.cuts(dta$values, thousands.separator = TRUE))
Unit: milliseconds
expr min lq mean median uq max neval
nice.cuts(dta$values, thousands.separator = TRUE) 32.67988 58.25709 99.26317 95.25195 136.7998 222.2178 100
小数据集
并且对于稍微大一点的数据集变得非常慢：
> dta <- data.frame(values=floor(runif(1000, 10000,90000)))
> microbenchmark(nice.cuts(dta$values, thousands.separator = TRUE),
+ times = 10)
Unit: milliseconds
expr min lq mean median uq max neval
nice.cuts(dta$values, thousands.separator = TRUE) 428.6821 901.2123 1154.097 1068.845 1679.052 1708.836 10
因此，我的问题相当简单，我想保留函数的当前功能，nice.cuts但我想让它运行得更快。
建议
- 我认为该
gsubfn元素需要相当多的时间，但我还没有想出如何让它更有效率。 - 我还认为采用变量的唯一值可能会加快速度。在我的真实数据中，我经常使用重复某些值的向量