Help for package gtools

two

asc(char, simplify = TRUE)

chr(ascii)

## ascii codes for lowercase letters
asc(letters)

## uppercase letters from ascii codes
chr(65:90)

## works on muti-character strings
(tmp <- asc("hello!"))
chr(tmp)

## Use 'simplify=FALSE' to return the result as a list
(tmp <- asc("hello!", simplify = FALSE))
chr(tmp)

## When simplify=FALSE the results can be...
asc(c("a", "e", "i", "o", "u", "y")) # a vector
asc(c("ae", "io", "uy")) # or a matrix

## When simplify=TRUE the results are always a list...
asc(c("a", "e", "i", "o", "u", "y"), simplify = FALSE)
asc(c("ae", "io", "uy"), simplify = FALSE)

ASCIIfy(x, bytes = 2, fallback = "?")

write(ASCIIfy(x), "file.txt")
cat(paste(ASCIIfy(x), collapse="\n"), "\n", sep="")
cities <- c("S\u00e3o Paulo", "Reykjav\u00edk")
print(cities)
ASCIIfy(cities, 1)
ASCIIfy(cities, 2)

athens <- "\u0391\u03b8\u03ae\u03bd\u03b1"
print(athens)
ASCIIfy(athens)

ask(msg = "Press <RETURN> to continue: ", con = stdin())

# use default prompt
ask()

silly <- function() {
  age <- ask("How old aroe you? ")
  age <- as.numeric(age)
  cat("In 10 years you will be", age + 10, "years old!\n")
}

assert(...)

capture(expression, collapse = "\n")

sprint(x, ...)

data(badDend)

baseOf(v, base = 10, len = 1)

# decimal representation
baseOf(123)

# binary representation
baseOf(123, base = 2)

# octal representation
baseOf(123, base = 8)

# hexadecimal representation
baseOf(123, base = 16)

# hexadecimal with more typical letter-notation
c(0:9, LETTERS)[baseOf(123, 16)]

# hexadecimal again, now showing a single string
paste(c(0:9, LETTERS)[baseOf(123, 16)], collapse = "")

# decimal representation but filling leading zeroes
baseOf(123, len = 5)

# and converting that back
sum(2^(4:0) * baseOf(123, len = 5))

# hashing and a tabular venn diagram derived from it
m <- matrix(sample(c(FALSE, TRUE), replace = TRUE, size = 300), ncol = 4)
colnames(m) <- c("strong", "colorful", "nice", "humorous")
names(dimnames(m)) <- c("samples", "features")
head(m)

m.val <- apply(m, 1, function(X) {
  return(sum(2^((ncol(m) - 1):0) * X))
})
m.val.rle <- rle(sort(m.val))
m.counts <- cbind(
  baseOf(m.val.rle$value, base = 2, len = ncol(m)),
  m.val.rle$lengths
)
colnames(m.counts) <- c(colnames(m), "num")
rownames(m.counts) <- apply(m.counts[, 1:ncol(m)], 1, paste, collapse = "")
m.counts[1 == m.counts[, "nice"] & 1 == m.counts[, "humorous"], , drop = FALSE]
m.counts[, "num", drop = TRUE]

binsearch(
  fun,
  range,
  ...,
  target = 0,
  lower = ceiling(min(range)),
  upper = floor(max(range)),
  maxiter = 100,
  showiter = FALSE
)

### Toy examples

# search for x=10
binsearch(function(x) x - 10, range = c(0, 20))

# search for x=10.1
binsearch(function(x) x - 10.1, range = c(0, 20))

### Classical toy example

# binary search for the index of 'M' among the sorted letters
fun <- function(X) {
  ifelse(LETTERS[X] > "M", 1,
    ifelse(LETTERS[X] < "M", -1, 0)
  )
}

binsearch(fun, range = 1:26)
# returns $where=13
LETTERS[13]

### Substantive example, from genetics
## Not run: 
library(genetics)
# Determine the necessary sample size to detect all alleles with
# frequency 0.07 or greater with probability 0.95.
power.fun <- function(N) 1 - gregorius(N = N, freq = 0.07)$missprob

binsearch(power.fun, range = c(0, 100), target = 0.95)

# equivalent to
gregorius(freq = 0.07, missprob = 0.05)

## End(Not run)

capwords(
  s,
  strict = FALSE,
  AP = TRUE,
  onlyfirst = FALSE,
  preserveMixed = FALSE,
  sep = " "
)

capwords("a function to capitalize words in a title")
capwords("a function to capitalize words in a title", AP = FALSE)

capwords("testing the iProduct for defects")
capwords("testing the iProduct for defects", strict = TRUE)
capwords("testing the iProduct for defects", onlyfirst = TRUE)
capwords("testing the iProduct for defects", preserveMixed = TRUE)

capwords("title_using_underscores_as_separators", sep = "_")

checkRVersion(quiet = FALSE)

try(
   ver <- checkRVersion()
)
print(ver)

combinations(n, r, v = 1:n, set = TRUE, repeats.allowed = FALSE)

permutations(n, r, v = 1:n, set = TRUE, repeats.allowed = FALSE)

combinations(3,2,letters[1:3])
combinations(3,2,letters[1:3],repeats=TRUE)

permutations(3,2,letters[1:3])
permutations(3,2,letters[1:3],repeats=TRUE)

## Not run: 
# To use large 'n', you need to change the default recusion limit
options(expressions=1e5)
cmat <- combinations(300,2)
dim(cmat) # 44850 by 2 

## End(Not run)

defmacro(..., expr)

strmacro(..., expr, strexpr)

 mul <- defmacro(a, b, expr={a*b}) 

####
# macro for replacing a specified missing value indicator with NA
# within a dataframe
###
setNA <- defmacro(df, var, values,
  expr = {
    df$var[df$var %in% values] <- NA
  }
)

# create example data using 999 as a missing value indicator
d <- data.frame(
  Grp = c("Trt", "Ctl", "Ctl", "Trt", "Ctl", "Ctl", "Trt", "Ctl", "Trt", "Ctl"),
  V1 = c(1, 2, 3, 4, 5, 6, 999, 8, 9, 10),
  V2 = c(1, 1, 1, 1, 1, 2, 999, 2, 999, 999),
  stringsAsFactors = TRUE
)
d

# Try it out
setNA(d, V1, 999)
setNA(d, V2, 999)
d

###
# Expression macro
###
plot.d <- defmacro(df, var, DOTS,
  col = "red", title = "", expr =
    plot(df$var ~ df$Grp, type = "b", col = col, main = title, ...)
)

plot.d(d, V1)
plot.d(d, V1, col = "blue")
plot.d(d, V1, lwd = 4) # use optional 'DOTS' argument

###
# String macro (note the quoted text in the calls below)
#
# This style of macro can be useful when you are reading
# function arguments from a text file
###
plot.s <- strmacro(DF, VAR,
  COL = "'red'", TITLE = "''", DOTS = "", expr =
    plot(DF$VAR ~ DF$Grp, type = "b", col = COL, main = TITLE, DOTS)
)

plot.s("d", "V1")
plot.s(DF = "d", VAR = "V1", COL = '"blue"')
plot.s("d", "V1", DOTS = "lwd=4") # use optional 'DOTS' argument

#######
# Create a macro that defines new functions
######
plot.sf <- defmacro(
  type = "b", col = "black",
  title = deparse(substitute(x)), DOTS, expr =
    function(x, y) plot(x, y, type = type, col = col, main = title, ...)
)

plot.red <- plot.sf(col = "red", title = "Red is more Fun!")
plot.blue <- plot.sf(col = "blue", title = "Blue is Best!", lty = 2)

plot.red(1:100, rnorm(100))
plot.blue(1:100, rnorm(100))

ddirichlet(x, alpha)

rdirichlet(n, alpha)

x <- rdirichlet(20, c(1, 1, 1))

ddirichlet(x, c(1, 1, 1))

foldchange(num, denom)

logratio2foldchange(logratio, base = 2)

foldchange2logratio(foldchange, base = 2)

a <- 1:21
b <- 21:1

f <- foldchange(a, b)

cbind(a, b, f)

getDependencies(
  pkgs,
  dependencies = c("Depends", "Imports", "LinkingTo"),
  installed = TRUE,
  available = TRUE,
  base = FALSE,
  recommended = FALSE
)

## Not run: 
## A locally installed package
#' getDependencies("MASS", installed = TRUE, available = FALSE)

## A package on CRAN
getDependencies("gregmisc", installed = FALSE, available = TRUE)

## Show base and recommended dependencies
getDependencies("MASS", available = FALSE, base = TRUE, recommended = TRUE)

## Download the set of packages necessary to support a local package
deps <- getDependencies("MyLocalPackage", available = FALSE)
download.packages(deps, destdir = "./R_Packages")

## End(Not run)

invalid(x)

invalid(NA)
invalid()
invalid(c(NA, NA, NULL, NA))

invalid(list(a = 1, b = NULL))

x <- try(log("A"))
invalid(x)

# example use in a function
myplot <- function(x, y) {
  if (invalid(y)) {
    y <- x
    x <- 1:length(y)
  }
  plot(x, y)
}
myplot(1:10)
myplot(1:10, NA)

keywords(topic)

## Show all valid R keywords
## Not run: 
keywords()

## Show keywords associated with the 'merge' function
keywords(merge)
keywords("merge")

## End(Not run)

lastAdd(fun)

## Print a couple of cute messages when R exits.
helloWorld <- function() cat("\nHello World!\n")
byeWorld <- function() cat("\nGoodbye World!\n")

.Last <- lastAdd(byeWorld)
.Last <- lastAdd(helloWorld)

## Not run: 
q("no")

## Should yield:
##
##   Save workspace image? [y/n/c]: n
##
##   Hello World!
##
##   Goodbye World!
##
##   Process R finished at Tue Nov 22 10:28:55 2005

## End(Not run)

loadedPackages(silent = FALSE)

loadedPackages()

logit(x, min = 0, max = 1)

inv.logit(x, min = 0, max = 1)

x <- seq(0, 10, by = 0.25)
xt <- logit(x, min = 0, max = 10)
cbind(x, xt)

y <- inv.logit(xt, min = 0, max = 10)
cbind(x, xt, y)

mixedsort(
  x,
  decreasing = FALSE,
  na.last = TRUE,
  blank.last = FALSE,
  numeric.type = c("decimal", "roman"),
  roman.case = c("upper", "lower", "both"),
  scientific = TRUE
)

mixedorder(
  x,
  decreasing = FALSE,
  na.last = TRUE,
  blank.last = FALSE,
  numeric.type = c("decimal", "roman"),
  roman.case = c("upper", "lower", "both"),
  scientific = TRUE
)

## compound & dose labels
Treatment <- c(
  "Control", "Aspirin 10mg/day", "Aspirin 50mg/day",
  "Aspirin 100mg/day", "Acetomycin 100mg/day",
  "Acetomycin 1000mg/day"
)

## ordinary sort puts the dosages in the wrong order
sort(Treatment)

## but mixedsort does the 'right' thing
mixedsort(Treatment)

## Here is a more complex example
x <- rev(c(
  "AA 0.50 ml", "AA 1.5 ml", "AA 500 ml", "AA 1500 ml",
  "EXP 1", "AA 1e3 ml", "A A A", "1 2 3 A", "NA", NA, "1e2",
  "", "-", "1A", "1 A", "100", "100A", "Inf"
))

mixedorder(x)

mixedsort(x) # Notice that plain numbers, including 'Inf' show up
# before strings, NAs at the end, and blanks at the
# beginning .

mixedsort(x, na.last = TRUE) # default
mixedsort(x, na.last = FALSE) # push NAs to the front

mixedsort(x, blank.last = FALSE) # default
mixedsort(x, blank.last = TRUE) # push blanks to the end

mixedsort(x, decreasing = FALSE) # default
mixedsort(x, decreasing = TRUE) # reverse sort order

## Roman numerals
chapters <- c(
  "V. Non Sequiturs", "II. More Nonsense",
  "I. Nonsense", "IV. Nonesensical Citations",
  "III. Utter Nonsense"
)
mixedsort(chapters, numeric.type = "roman")

## Lower-case Roman numerals
vals <- c(
  "xix", "xii", "mcv", "iii", "iv", "dcclxxii", "cdxcii",
  "dcxcviii", "dcvi", "cci"
)
(ordered <- mixedsort(vals, numeric.type = "roman", roman.case = "lower"))
roman2int(ordered)

## Control scientific notation for number matching:
vals <- c("3E1", "2E3", "4e0")

mixedsort(vals) # With scientfic notation
mixedsort(vals, scientific = FALSE) # Without scientfic notation

na.replace(x, replace, ...)

x <- c(1, 2, 3, NA, 6, 7, 8, NA, NA)

# Replace with a specified value
na.replace(x, "999")

# Replace with the calculated median
na.replace(x, median, na.rm = TRUE)

odd(x)

even(x)

odd(4)
even(4)

odd(1:10)
even(1:10)

permute(x)

x <- 1:10
permute(x)

quantcut(x, q = 4, na.rm = TRUE, ...)

## create example data
# testonly{
set.seed(1234)
# }
x <- rnorm(1000)

## cut into quartiles
quartiles <- quantcut(x)
table(quartiles)

## cut into deciles
deciles.1 <- quantcut(x, 10)
table(deciles.1)
# or equivalently
deciles.2 <- quantcut(x, seq(0, 1, by = 0.1))

# testonly{
stopifnot(identical(deciles.1, deciles.2))
# }

## show handling of 'tied' quantiles.
x <- round(x) # discretize to create ties
stem(x) # display the ties
deciles <- quantcut(x, 10)

table(deciles) # note that there are only 5 groups (not 10)
# due to duplicates

roman2int(roman)

roman2int(c("I", "V", "X", "C", "L", "D", "M"))

# works regardless of case
roman2int("MMXVI")
roman2int("mmxvi")

# works beyond R's limit of 3899
val.3899 <- "MMMDCCCXCIX"
val.3900 <- "MMMCM"
val.4000 <- "MMMM"
as.numeric(as.roman(val.3899))
as.numeric(as.roman(val.3900))
as.numeric(as.roman(val.4000))

roman2int(val.3899)
roman2int(val.3900)
roman2int(val.4000)

running(
  X,
  Y = NULL,
  fun = mean,
  width = min(length(X), 20),
  allow.fewer = FALSE,
  pad = FALSE,
  align = c("right", "center", "left"),
  simplify = TRUE,
  by,
  ...
)

# show effect of pad
running(1:20, width = 5)
running(1:20, width = 5, pad = TRUE)

# show effect of align
running(1:20, width = 5, align = "left", pad = TRUE)
running(1:20, width = 5, align = "center", pad = TRUE)
running(1:20, width = 5, align = "right", pad = TRUE)

# show effect of simplify
running(1:20, width = 5, fun = function(x) x) # matrix
running(1:20, width = 5, fun = function(x) x, simplify = FALSE) # list

# show effect of by
running(1:20, width = 5) # normal
running(1:20, width = 5, by = 5) # non-overlapping
running(1:20, width = 5, by = 2) # starting every 2nd

# Use 'pad' to ensure correct length of vector, also show the effect
# of allow.fewer.
par(mfrow = c(2, 1))
plot(1:20, running(1:20, width = 5, allow.fewer = FALSE, pad = TRUE), type = "b")
plot(1:20, running(1:20, width = 5, allow.fewer = TRUE, pad = TRUE), type = "b")
par(mfrow = c(1, 1))

# plot running mean and central 2 standard deviation range
# estimated by *last* 40 observations
dat <- rnorm(500, sd = 1 + (1:500) / 500)
plot(dat)
sdfun <- function(x, sign = 1) mean(x) + sign * sqrt(var(x))
lines(running(dat, width = 51, pad = TRUE, fun = mean), col = "blue")
lines(running(dat, width = 51, pad = TRUE, fun = sdfun, sign = -1), col = "red")
lines(running(dat, width = 51, pad = TRUE, fun = sdfun, sign = 1), col = "red")

# plot running correlation estimated by last 40 observations (red)
# against the true local correlation (blue)
sd.Y <- seq(0, 1, length = 500)

X <- rnorm(500, sd = 1)
Y <- rnorm(500, sd = sd.Y)

plot(running(X, X + Y, width = 20, fun = cor, pad = TRUE), col = "red", type = "s")

r <- 1 / sqrt(1 + sd.Y^2) # true cor of (X,X+Y)
lines(r, type = "l", col = "blue")

scat(...)

options(DEBUG = NULL) # makee sure DEBUG isn't set
scat("Not displayed")

options(DEBUG = TRUE)
scat("This will be displayed immediately (even in R BATCH output \n")
scat("files), provided options()$DEBUG is TRUE.")

script_file(fail = c("stop", "warning", "quiet"))

script_path(fail = c("stop", "warning", "quiet"))

getwd()
commandArgs(trailingOnly = FALSE)

script_file("warning")
script_path("warning")

setTCPNoDelay(socket, value = TRUE)

## Not run: 
host <- "www.r-project.org"
socket <- make.socket(host, 80)
print(socket)
setTCPNoDelay(socket, TRUE)

write.socket(socket, "GET /\n\n")
write.socket(socket, "A")
write.socket(socket, "B\n")
while ((str <- read.socket(socket)) > "") {
  cat(str)
}
close.socket(socket)

## End(Not run)

smartbind(..., list, fill = NA, sep = ":", verbose = FALSE)

df1 <- data.frame(A = 1:10, B = LETTERS[1:10], C = rnorm(10))
df2 <- data.frame(A = 11:20, D = rnorm(10), E = letters[1:10])

# rbind would fail
## Not run: 
rbind(df1, df2)
# Error in match.names(clabs, names(xi)) : names do not match previous
# names:
# 	D, E

## End(Not run)
# but smartbind combines them, appropriately creating NA entries
smartbind(df1, df2)

# specify fill=0 to put 0 into the missing row entries
smartbind(df1, df2, fill = 0)

split_path(x, depth_first = TRUE)

stars.pval(p.value)

p.val <- c(0.0004, 0.0015, 0.013, 0.044, 0.067, 0.24)
stars.pval(p.val)

stat_mode(x, na.rm = TRUE, ties = c("all", "first", "last", "missing"), ...)

# Character vector
chr_vec <- c("a", "d", "d", "h", "h", NA, NA) # Multiple modes
stat_mode(x = chr_vec)
stat_mode(x = chr_vec, na.rm = FALSE)
stat_mode(x = chr_vec, na.rm = FALSE, ties = "first")
stat_mode(x = chr_vec, na.rm = FALSE, ties = "last")

# - # Numeric vector
# See that it keeps the original vector type
num_vec <- c(2, 3, 3, 4, 4, NA, NA)
stat_mode(x = num_vec)
stat_mode(x = num_vec, na.rm = FALSE)
stat_mode(x = num_vec, na.rm = FALSE, ties = "first")
stat_mode(x = num_vec, na.rm = FALSE, ties = "last")

# The default option is ties="all" but it is very easy for the user to control
# the ties without changing this parameter.
# Select always just one mode, being that the first mode
stat_mode(x = num_vec)[1]

# Select the first and the second stat_mode
stat_mode(x = num_vec)[c(1, 2)]

# Logical Vectors
stat_mode(x = c(TRUE, TRUE))
stat_mode(x = c(FALSE, FALSE, TRUE, TRUE))

# - # Single element cases
stat_mode(x = c(NA_real_))
stat_mode(x = 2)
stat_mode(x = NA)
stat_mode(x = c("a"))

# Not allowing multiple stat_mode, returning NA if that happens
stat_mode(x = c(1, 1, 2, 2), multiple_modes = FALSE) # multiple stat_mode
stat_mode(x = c(1, 1), multiple_modes = FALSE) # single mode

# Empty vector cases
# The ties of any empty vector will be itself (an empty vector of the same type)
stat_mode(x = double())
stat_mode(x = complex())
stat_mode(x = vector("numeric"))
stat_mode(x = vector("character"))

unByteCode(fun)

assignEdgewise(name, env, value)

unByteCodeAssign(fun)

data(badDend)
dist2 <- function(x) as.dist(1 - cor(t(x), method = "pearson"))
hclust1 <- function(x) hclust(x, method = "single")

distance <- dist2(badDend)
cluster <- hclust1(distance)

dend <- as.dendrogram(cluster)
## Not run: 
## In R 2.3.0 and earlier crashes with a node stack overflow error
plot(dend)
## Error in xy.coords(x, y, recycle = TRUE) : node stack overflow

## End(Not run)

## convert stats:::plotNode from byte-code to interpreted-code
## (no longer available unless assignEdgewise is defined by the user)
## unByteCodeAssign(stats:::plotNode)
## illustrated in https://stackoverflow.com/questions/16559250/error-in-heatmap-2-gplots

# increase recursion limit
options("expressions" = 5e4)

# now the function does not crash
plot(dend)

gtools: Various R Programming Tools

Description

Author(s)

See Also

Convert between characters and ASCII codes

Description

Usage

Arguments

Value

Functions

Author(s)

See Also

Examples

Convert Characters to ASCII

Description

Usage

Arguments

Value

Note

Author(s)

See Also

Examples

Display a prompt and collect the user's response

Description

Usage

Arguments

Details

Value

Author(s)

See Also

Examples

Defunct Functions in package gtools

Description

Usage

Arguments

Details

See Also

Dataset That Crashes Base:::Plot.Dendogram with 'Node Stack Overflow'

Description

Format

Note

Examples

Transform an integer to an array of base-n digits

Description

Usage

Arguments

Details

Author(s)

Examples

Binary Search

Description

Usage

Arguments

Details

Value

Note

Author(s)

See Also

Examples

Capitalize Words for Titles

Description

Usage

Arguments

Details

Value

Author(s)

References

See Also

Examples

Check if a newer version of R is available

Description

Usage

Arguments

Details

Value

Note

Author(s)

See Also

Examples

Enumerate the Combinations or Permutations of the Elements of a Vector

Defunct Functions in package `gtools`