functions and associated methods for doing logical comparisons with ties

tied comparisons 1 functions.r

# tied greater than
`%tgt%` <- function(x, y) {
	v <- x > y
	v[x == y] <- 0.5
	v
}

tgt <- function(x, y) {
	v <- x > y
	v[x == y] <- 0.5
	v
}

# tied less than
`%tlt%` <- function(x, y) {
	v <- x < y
	v[x == y] <- 0.5
	v
}

tlt <- function(x, y) {
	v <- x < y
	v[x == y] <- 0.5
	v
}

# tied triple test
`%ttt%` <- function(x, y) {
	v <- x != y
	v[x < y] <- -1
	v[x > y] <- 1
	class(v) <- c("ttt", "integer")
	v
}

ttt <- function(x, y) {
	v <- x != y
	v[x < y] <- -1
	v[x > y] <- 1
	class(v) <- c("ttt", "integer")
	v
}

tied comparisons 2 methods.r

# print method
print.ttt <- function(x, symbol=TRUE, ...) {
	if (symbol) x <- c("<", "=", ">")[x + 2]
	print(unclass(x), ...)
}

# table methods
table <- function(...) {
	UseMethod("table")
}

table.default <- function(...) {
	base::table(...)
}

table.ttt <- function(...) {
	ta <- table.default(...)
	names(ta) <- c("<", "=", ">")
	ta
}

# modified print.data.frame method
print.data.frame <- function(x, ...) {
	ittt <- sapply(x, is.ttt)
	x[ittt] <- lapply(x[ittt], function(x) c("<", "=", ">")[x + 2])

	base::print.data.frame(x, ...)
}

tied comparisons 3 examples.r

1:5 %tlt% 3
1:5 %tgt% 3
1:5 %ttt% 3

ttt(1:3, 2)
print(ttt(1:3, 2), FALSE)

c(1, 4, 3, 1) %tlt% c(1, 3, 3, 2)
c(1, 4, 3, 1) %tgt% c(1, 3, 3, 2)
c(1, 4, 3, 1) %ttt% c(1, 3, 3, 2)

dtf <- data.frame(x=1:5, y=3)
dtf$`?` <- ttt(dtf$x, dtf$y)
dtf

###
x <- c(8, 4, 6, 8, 9, 6, 5, 7, 0, 3, 2, 1, 5, 6, 4, 7, 6,
       3, 1, 9, 5, 6, 7, 7, 4, 5, 8, 6, 2, 5, 9, 5, 4, 8)
y <- c(1, 3, 2, 4, 6, 0, 5, 3, 7, 5, 7, 4, 5, 6, 0, 1, 4,
       2, 4, 3, 1, 5, 3, 9, 2, 2, 4, 7, 5, 6, 8)

ou <- outer(sort(x), sort(y), "%ttt%")
ta <- table(ou)

pa <- capture.output(ta)

par(mar=c(1, 2, 3, 2), family="PT Mono")
image(ou, col=topo.colors(length(ta)), axes=FALSE)
title(pa)
box()