加速用于创建方便的地图和图表组的功能

Question

背景

在进行了有益的讨论之后，我从 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

可用于生成惊人的传说：

这在为 choropleth maps 生成数据时非常有用，我一直在使用它。

问题

挑战与表现不佳有关。该功能似乎很慢。

非常小的数据集

对于 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 元素需要很多时间，但我还没想好怎么才能让它更有效率。
我也在想，取变量的唯一值可能会稍微加快速度。在我的真实数据中，我经常使用向量，其中重复某些值

Answer 1

您对完整的输入向量进行所有标签清理：首先在 cut2 之后生成一个字符向量，然后对该向量执行大量正则表达式。但是，您只是在修改标签。

因此，生成cut_breaks后，我会先生成正确格式的标签：cut_labels。我在下面的 cut.labels 的新版本中完成了此操作。与原始基准对比显示出巨大的改进：

> require(microbenchmark)
> dta <- data.frame(values=floor(runif(1000, 10000,90000)))
> microbenchmark(nice.cuts(dta$values, thousands.separator = TRUE),
+   nice.cuts2(dta$values, thousands.separator = TRUE))
Unit: milliseconds
                                               expr      min        lq     mean    median        uq        max neval cld
  nice.cuts(dta$values, thousands.separator = TRUE) 720.1378 815.51782 902.9218 923.97881 968.39036 1208.00434   100   b
 nice.cuts2(dta$values, thousands.separator = TRUE)  11.4147  15.18232  16.6196  16.46937  17.05305   29.91089   100  a 
>

新版本nice.cuts

我采用了 cuts_variable 的标签并将原始函数的所有步骤应用于这些标签。然后我用这些新标签覆盖 cuts_variable 的标签。

nice.cuts2 <- 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)

  cuts_labels <- levels(cuts_variable)

  # Check if variable is total or with decimals
  if (all(cut_breaks %% 1 == 0)) {
    # Variable is integer
    cuts_labels <- gsubfn('\[\s*(\d+),\s*(\d+)[^0-9]+',
                         ~paste0(x, '-',as.numeric(y)-1),
                         as.character(cuts_labels))
  } else {
    # Variable is not integer
    # Create clean cuts
    cuts_labels <- gsubfn('\[\s*([0-9]+\.*[0-9]*),\s*(\d+\.\d+).*',
                         ~paste0(x, '-', as.numeric(y)- 0.01),
                         as.character(cuts_labels))
  }

  # Clean Inf
  cuts_labels <- gsub("Inf", max(variable), cuts_labels)

  # Clean punctuation
  cuts_labels <- sub("\[(.*), (.*)\]", "\1 - \2", cuts_labels)

  # Replace strings with spaces
  cuts_labels <- gsub("-"," - ",cuts_labels, fixed = TRUE)

  # Trim white spaces
  cuts_labels <- trimws(cuts_labels)


  if (thousands.separator == TRUE) {
    cuts_labels <- sapply(strsplit(cuts_labels, " - "),
                                 function(x) paste(prettyNum(x,
                                                             big.mark = ",",
                                                             preserve.width = "none"),
                                                   collapse = " - "))
  }

  levels(cuts_variable) <- cuts_labels
  cuts_variable
}

加速用于创建方便的地图和图表组的功能

Speeding up a function used to create convenient groups for mapping and charting

r

performance

function

vector

hmisc

背景

函数

结果

问题

非常小的数据集

小数据集

建议