add r
This commit is contained in:
@@ -0,0 +1,6 @@
|
||||
`%o%` <- function(f, g) {
|
||||
comp <- function(...) {
|
||||
return(f(g(...)))
|
||||
}
|
||||
return(comp)
|
||||
}
|
||||
@@ -0,0 +1,35 @@
|
||||
n_diag <- function(mat, n) {
|
||||
stopifnot("Matrix not quadratic" = nrow(mat) == ncol(mat))
|
||||
stopifnot("Matrix does not have such a (sub)diagonal" = abs(n) < nrow(mat))
|
||||
dg <- c()
|
||||
for (i in (1:(nrow(mat)-abs(n)))) {
|
||||
elem <- if (n > 0) {
|
||||
mat[i, i+n]
|
||||
} else {
|
||||
mat[i+abs(n), i]
|
||||
}
|
||||
dg <- c(dg, elem)
|
||||
}
|
||||
return(dg)
|
||||
}
|
||||
|
||||
`n_diag<-` <- function(x, value, n) {
|
||||
stopifnot("Matrix not quadratic" = nrow(mat) == ncol(mat))
|
||||
stopifnot("Matrix does not have such a (sub)diagonal" = abs(n) < nrow(mat))
|
||||
stopifnot("Subdiagonal length and replacement do not match" = length(value) == nrow(mat) - abs(n))
|
||||
for (i in (1:(nrow(mat)-abs(n)))) {
|
||||
elem <- if (n > 0) {
|
||||
mat[i, i+n] <- value[i]
|
||||
} else {
|
||||
mat[i+abs(n), i] <- value[i]
|
||||
}
|
||||
}
|
||||
return(mat)
|
||||
}
|
||||
|
||||
mat <- matrix(1:16, nrow=4)
|
||||
print(mat)
|
||||
print(n_diag(mat, 2))
|
||||
|
||||
n_diag(mat, -3) <- 1
|
||||
print(mat)
|
||||
@@ -0,0 +1,178 @@
|
||||
## 1.
|
||||
|
||||
size <- function(mat) {
|
||||
return(attr(mat, "size"))
|
||||
}
|
||||
|
||||
`size<-` <- function(x, value) {
|
||||
attributes(x)$size <- value
|
||||
return(x)
|
||||
}
|
||||
|
||||
|
||||
## 2.
|
||||
|
||||
sudoku <- function(mat, n=NULL, m=NULL) {
|
||||
attributes(mat)$class <- "sudoku"
|
||||
if (!is.matrix(mat)) {
|
||||
stopifnot("If mat is not a matrix, at n and m have to be specified" = !is.null(n) && !is.null(m))
|
||||
mat <- matrix(mat, nrow=n*m)
|
||||
} else if (is.null(n)) {
|
||||
n <- nrow(mat) / m
|
||||
} else if (is.null(m)) {
|
||||
m <- nrow(mat) / n
|
||||
}
|
||||
size(mat) <- c(n, m)
|
||||
return(mat)
|
||||
}
|
||||
|
||||
|
||||
## 3.
|
||||
|
||||
is_sudoku <- function(s) {
|
||||
if (is.null(size(s))) {
|
||||
return(FALSE)
|
||||
}
|
||||
n <- size(s)[1]
|
||||
m <- size(s)[2]
|
||||
checks <- c(nrow(s) == ncol(s),
|
||||
nrow(s) == n*m,
|
||||
attr(s, "class") == "sudoku",
|
||||
s %in% c(NA, (1:(n*m))))
|
||||
return(all(checks))
|
||||
}
|
||||
|
||||
|
||||
|
||||
## 4.
|
||||
|
||||
is_sub_valid <- function(x) {
|
||||
dups <- any(duplicated(x))
|
||||
in_range <- all(x %in% c(NA, (1:length(x))))
|
||||
return(in_range && !dups)
|
||||
}
|
||||
|
||||
|
||||
|
||||
## 5.
|
||||
|
||||
partition_index <- function(n, m) {
|
||||
m1 <- matrix(rep(1:(n*m), each=n), nrow=n*m)
|
||||
m2 <- m1[, rep(1:n, each=m)]
|
||||
return(m2)
|
||||
}
|
||||
partition_index(3,2)
|
||||
|
||||
|
||||
|
||||
## 6.
|
||||
|
||||
is_valid <- function(s) {
|
||||
stopifnot("s is not a sudoku!" = is_sudoku(s))
|
||||
n <- size(s)[1]
|
||||
m <- size(s)[2]
|
||||
rows_valid <- sapply(1:(n*m), function(r) is_sub_valid(s[r,]))
|
||||
cols_valid <- sapply(1:(n*m), function(c) is_sub_valid(s[,c]))
|
||||
part <- partition_index(n, m)
|
||||
fields_valid <- sapply(1:(n*m), function(i) is_sub_valid(s[part == i]))
|
||||
return(all(c(fields_valid, cols_valid, fields_valid)))
|
||||
}
|
||||
|
||||
is_filled_in <- function(s) {
|
||||
return(!any(is.na(s)))
|
||||
}
|
||||
|
||||
is_solved <-function(s) {
|
||||
return(is_valid(s) && is_filled_in(s))
|
||||
}
|
||||
|
||||
|
||||
## 7.
|
||||
|
||||
is_solution_of <- function(s, s_star) {
|
||||
return(is_solved(s_star) && all(s == s_star, na.rm=TRUE))
|
||||
}
|
||||
|
||||
|
||||
## 8.
|
||||
|
||||
print_non_valid <- function(s, print_missing=T) {
|
||||
stopifnot("s is not a sudoku!" = is_sudoku(s))
|
||||
s <- ""
|
||||
if (print_missing) {
|
||||
missing_fields <- which(is.na(s), arr.ind=T)
|
||||
if (nrow(missing_fields) > 0)
|
||||
sapply(1:nrow(missing_fields), function(r) cat("missing value at ",
|
||||
missing_fields[r,1],
|
||||
",",
|
||||
missing_fields[r,2],
|
||||
"\n",
|
||||
sep=""))
|
||||
}
|
||||
n <- size(s)[1]
|
||||
m <- size(s)[2]
|
||||
rows_invalid <- which(sapply(1:(n*m), function(r) !is_sub_valid(s[r,])))
|
||||
sapply(rows_invalid, function(x) cat("row ",
|
||||
x,
|
||||
" is invalid\n",
|
||||
sep=""))
|
||||
cols_invalid <- which(sapply(1:(n*m), function(c) !is_sub_valid(s[,c])))
|
||||
sapply(cols_invalid, function(x) cat("column ",
|
||||
x,
|
||||
" is invalid\n",
|
||||
sep=""))
|
||||
part <- partition_index(n, m)
|
||||
fields <- matrix(1:(n*m), nrow=m)
|
||||
fields_invalid <- which(apply(fields, c(1,2), function(i) !is_sub_valid(s[part == i])), arr.ind=T)
|
||||
if (length(fields_invalid) > 0) {
|
||||
sapply(1:nrow(fields_invalid), function(r) cat("field ",
|
||||
fields_invalid[r,1],
|
||||
",",
|
||||
fields_invalid[r,2],
|
||||
" is invalid\n",
|
||||
sep=""))
|
||||
}
|
||||
return(NULL)
|
||||
}
|
||||
|
||||
|
||||
|
||||
## TEST
|
||||
|
||||
x <- matrix(
|
||||
c(5,2,6,4,3,1,6,1,3,2,5,4,3,4,1,5,2,6,2,6,4,3,1,5,1,3,5,6,4,2,4,5,2,1,6,3),
|
||||
ncol = 6)
|
||||
is_sudoku(x)
|
||||
|
||||
s <- sudoku(x, 3, 2)
|
||||
s
|
||||
size(s)
|
||||
is_sudoku(s)
|
||||
is_filled_in(s)
|
||||
is_valid(s)
|
||||
is_solved(s)
|
||||
print_non_valid(s)
|
||||
|
||||
size(s) <- c(2, 3)
|
||||
is_sudoku(s)
|
||||
is_filled_in(s)
|
||||
is_valid(s)
|
||||
is_solved(s)
|
||||
|
||||
s_na <- s
|
||||
s_na[sample(36, 18)] <- NA
|
||||
s_na
|
||||
is_sudoku(s_na)
|
||||
is_filled_in(s_na)
|
||||
is_valid(s_na)
|
||||
is_solved(s_na)
|
||||
print_non_valid(s_na)
|
||||
|
||||
s_not <- sudoku(sample(1:6, 36, replace=T), 2, 3)
|
||||
s_not[sample(36, 18)] <- NA
|
||||
s_not
|
||||
is_sudoku(s_not)
|
||||
is_filled_in(s_not)
|
||||
is_valid(s_not)
|
||||
is_solved(s_not)
|
||||
print_non_valid(s_not, print_missing=FALSE)
|
||||
Reference in New Issue
Block a user