1# File src/library/base/R/cut.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2018 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19cut <- function(x, ...) UseMethod("cut") 20 21cut.default <- 22 function (x, breaks, labels = NULL, include.lowest = FALSE, 23 right = TRUE, dig.lab = 3L, ordered_result = FALSE, ...) 24{ 25 if (!is.numeric(x)) stop("'x' must be numeric") 26 if (length(breaks) == 1L) { 27 if (is.na(breaks) || breaks < 2L) 28 stop("invalid number of intervals") 29 nb <- as.integer(breaks + 1) # one more than #{intervals} 30 dx <- diff(rx <- range(x, na.rm = TRUE)) 31 if(dx == 0) { 32 dx <- if(rx[1L] != 0) abs(rx[1L]) else 1 33 breaks <- seq.int(rx[1L] - dx/1000, rx[2L] + dx/1000, 34 length.out = nb) 35 } else { 36 breaks <- seq.int(rx[1L], rx[2L], length.out = nb) 37 breaks[c(1L, nb)] <- c(rx[1L] - dx/1000, rx[2L] + dx/1000) 38 } 39 } else nb <- length(breaks <- sort.int(as.double(breaks))) 40 if (anyDuplicated(breaks)) stop("'breaks' are not unique") 41 codes.only <- FALSE 42 if (is.null(labels)) {#- try to construct nice ones .. 43 for(dig in dig.lab:max(12L, dig.lab)) { 44 ## 0+ avoids printing signed zeros as "-0" 45 ch.br <- formatC(0+breaks, digits = dig, width = 1L) 46 if(ok <- all(ch.br[-1L] != ch.br[-nb])) break 47 } 48 labels <- 49 if(ok) paste0(if(right)"(" else "[", 50 ch.br[-nb], ",", ch.br[-1L], 51 if(right)"]" else ")") 52 else paste0("Range_", seq_len(nb - 1L)) 53 if (ok && include.lowest) { 54 if (right) 55 substr(labels[1L], 1L, 1L) <- "[" # was "(" 56 else 57 substring(labels[nb-1L], 58 nchar(labels[nb-1L], "c")) <- "]" # was ")" 59 } 60 } else if (is.logical(labels) && !labels) 61 codes.only <- TRUE 62 else if (length(labels) != nb - 1L) 63 stop("lengths of 'breaks' and 'labels' differ") 64 code <- .bincode(x, breaks, right, include.lowest) 65 if(codes.only) code 66 else factor(code, seq_along(labels), labels, ordered = ordered_result) 67} 68 69## called from image.default and for use in packages. 70.bincode <- function(x, breaks, right = TRUE, include.lowest = FALSE) 71 .Internal(bincode(x, breaks, right, include.lowest)) 72 73