List all factors and find primes

This function lists all factors of a number:

factors <- function(n) {
	p <- 1:floor(n/2)
	p <- c(p,n)
	d <- n/p
	return(d[d == round(d,0)])
}

And then this uses the ‘factors’ to list all prime numbers between ‘min’ and ‘max’. This is just for fun – it doesn’t work with large numbers.

prime <- function (max, min = 2) {
	t <- min
	vec <- NULL
	while (t <= max) {
		if (length(factors(t)) == 2) {
			vec <- c(vec, t)
		}
		t <- t + 1
	}
	return(vec)
}
Advertisements

Find quantiles in R

This code returns a vector of n (‘n’) quantiles for a numerical vector (‘variable’), e.g. quant(x, 10).

quant <- function(variable, n) {
    x <- data.frame(id = 1:length(variable), variable = variable)
    x <- x[order(x$variable),]
    cases <- length(variable[!is.na(variable)])
    sizes <- floor(cases/n)
    breaks <- rep(sizes, n)
    left <- cases - (sizes * n)
    if(left > 0) {
        breaks[1:left] <- rep(sizes + 1)
    }
    vec <- NULL
    for (u in 1:n) {
        vec <- c(vec, rep(u, breaks[u]))
    }
    vec <- c(vec, rep(NA, length(variable) - cases))
    return(vec[order(x$id)])
}

Edit – better method (borrowing heavily from dplyr::ntile):

ntile_ <- function(x, n) {
    b <- x[!is.na(x)]
    q <- floor((n * (rank(b, ties.method = "first") - 1)/length(b)) + 1)
    d <- rep(NA, length(x))
    d[!is.na(x)] <- q
    return(d)
}

Settling up bills

If you live with some friends in a shared house then you’ve probably got into the situation where you’ve all paid various bills, and you need to settle up. This R code finds an efficient number of transactions between you. There can be any number of people involved, so long as ‘names’ and ‘payments’ are the same length. Enter the total each person has paid, rather than each bill separately.

names <- c("A", "B", "C", "D", "E", "F")
payments <- c(12, 10, 50, 40, 28, 28)
n <- length(names)
owed <- payments - mean(payments)
credits <- ifelse(owed > 0, owed, 0)
debts <- ifelse(owed < 0, -owed, 0)
sm <- matrix(rep(1, n^2), n, n)
y <- 1
while (y <= n) {
	settles <- NULL
	x <- 1
	debt <- debts[y]
	while (x <= n) {
		settles[x] <- ifelse(debt > credits[x], credits[x], debt)
		debt <- debt - settles[x]
		x <- x + 1
	}
	credits <- credits - settles
	sm[y,] <- settles
	y <- y + 1
}
sm <- round(sm, 2)
y <- 1
while (y <= n) {
	x <- 1
	while (x <= n) {
		sm[x,y] <- ifelse(sm[x,y] == 0, "x", paste(names[x], "owes", names[y], sm[x,y]))
		x <- x + 1
	}
	y <- y + 1
}
as.list(sm[sm != "x"])

Sudoku solver in R

Here’s some R code that solves sudokus. There is actually a whole PACKAGE dedicated to this problem (http://cran.r-project.org/web/packages/sudoku/sudoku.pdf) but I thought I’d give it a shot myself.

# load the package 'stringr' for the str_count function and save your sudoku as a tab delimited text file, or input it manually as a matrix 'puz'

puz <- as.matrix(read.csv("sudpuz.txt", sep="\t", header = F))
y <- c(puz)

# make keys

sq_start <- c(1, 4, 7, 28, 31, 34, 55, 58, 61)
key <- matrix(1:81, 9, 9)
squares <- function(q) {
	c(q:(q+2), (q+9):(q+11), (q+18):(q+20))
	}
key <- rbind(t(key), key, t(sapply(sq_start, squares)))

rel <- data.frame(box = 1:81)
rel$cols <- ceiling(rel$box/9)
rel$rows <- rep(10:18, 9)
rel$sq <- c(rep(c(19,19,19,20,20,20,21,21,21),3), rep(c(22,22,22,23,23,23,24,24,24),3), rep(c(25,25,25,26,26,26,27,27,27),3))

# find all related numbers. x is the box

allnumsF <- function(x) {
	cols <- paste(y[key[rel[x,2],]], collapse = "NA")
	rows <- paste(y[key[rel[x,3],]], collapse = "NA")
	sqs <-  paste(y[key[rel[x,4],]], collapse = "NA")
	nums <- paste(cols, rows, sqs, collapse = "NA")
	nums <- gsub("NA", "", nums)
	return(nums)
}

# find candidates (x is the list of related numbers within a box)

poss <- function (x) {
	findn <- function(q) {
		return(ifelse(grepl(q, x), "", q))
	}
	nums <- sapply(1:9, findn)
	return(paste(nums, collapse = ""))
}

# replace boxes in y where there is only one option (cand is the vector of candidates)

onlyplace <- function(cand, y) {
    for (u in 1:27) {
	    for (t in 1:9) {
	    	x <- grep(t, cand[c(key[u, ])])
	    	if (length(x) == 1) {
	    		y[key[u, x]] <- t
	    	}
    	}		
    }
    return(y)
}

# determine solved status, where y is the puzzle vector. 1 = solved, 2 = error, 3 = incomplete

status <- function (y) {
	solvemat <- matrix(1:243, 27, 9)
	for (u in 1:27) {
		for (v in 1:9) {
			solvemat[u, v] <- str_count(paste(y[key[u,]], collapse = "NA"), as.character(v))
		}
	}
	if (sum(ifelse(solvemat == 1, 1, 0)) == 243) {
		return(1)
	} else {
		if (sum(ifelse(solvemat > 1, 1, 0)) > 1) {
			return(2)
		} else {
			return(3)
		}
	}
}

# master function, where x is the puzzle vector

solver <- function (x) {
	allnums <- sapply(1:81, allnumsF)
	cand <- sapply(allnums, poss)
	cand <- ifelse(is.na(y),gsub(0, "", cand),y)
	y <- onlyplace(cand, y)
	return(list(y, allnums, cand))
}

result <- solver(y)
y <- result[[1]]
allnums <- result[[2]]
cand <- result[[3]]

# iterate and solve

iter <- 0
status_y <- status(y)
while (status_y == 3 && iter < 20) {
	status_y <- status(y)
	y <- solver(y)[[1]]
	iter <- iter + 1
}

matrix(y, 9, 9)
status(y)