Merge branch 'master' of gitea:christian/uni

sose2021/r/w02/P02-1-exerc.R

@@ -0,0 +1,31 @@
+NUMERIC_TYPES <- c("double", "integer")
+
+lsq <- function(X, y) {
+    # TODO
+    stopifnot("X may not be empty" = length(X) > 0)
+    stopifnot("y may not be empty" = length(y) > 0)
+    stopifnot("X must be numeric" = typeof(X) %in% NUMERIC_TYPES)
+    stopifnot("y must be numeric" = typeof(y) %in% NUMERIC_TYPES)
+    stopifnot("X must be matrix" = is.matrix(X))
+    stopifnot("y must be vector or matrix with one column" = is.vector(y) || (is.matrix(y) && ncol(y) == 1))
+    stopifnot("dimensions of X and y do not fit" = (is.vector(y) && nrow(X) == length(y)) || (is.matrix(y) && nrow(y) == nrow(X)))
+    stopifnot("y may not contain NA" = all(!is.na(y)))
+    stopifnot("X may not contain NA" = all(!is.na(X)))
+    A <- t(X) %*% X
+    stopifnot("det(t(X) %*% X) must not be zero" = det(A) != 0)
+    solve(A, t(X) %*% y) 
+}
+
+lsq(matrix(1:6, nrow=3), 1:3)
+lsq(matrix(runif(6), nrow=3), matrix(runif(3), ncol=1))
+lsq(matrix(letters[1:6] , nrow=2), 1:3)
+lsq(matrix(1:6, nrow=3), list(1,2,3))
+lsq(1:6, 1:3)
+lsq(matrix(1:6, nrow=3), array(1:3, dim=c(1,1,3)))
+lsq(matrix(1:6, nrow=3), 1:4)
+lsq(matrix(1:6, nrow=3), matrix(1:3, nrow=1))
+lsq(matrix(1:6, nrow=3), matrix(1:6, nrow=3))
+lsq(matrix(double(0), nrow=0, ncol=0), matrix(double(0), nrow=0, ncol=0))
+lsq(matrix(1:6, nrow=3), c(1,NA,3))
+lsq(matrix(c(1:5, NA), nrow=3), 1:3)
+lsq(matrix(c(1,1,2,1,1,2), nrow=3), 1:3)

sose2021/r/w02/P02-2-exerc.R

@@ -0,0 +1,35 @@
+my_matrix <- function(vec, nrow=NULL, ncol=NULL, colnames=NULL, rownames=NULL) {
+    stopifnot("at least one of nrow or ncol has to be specified" = !is.null(nrow) || !is.null(ncol))
+    if (is.null(nrow)) {
+        stopifnot("incompatible length" = length(vec) %% ncol == 0)
+        nrow <- length(vec) / ncol
+    } else if (is.null(ncol)) {
+        stopifnot("incompatible length" = length(vec) %% nrow == 0)
+        ncol <- length(vec) / nrow
+    } else if (length(vec) == 1) {
+        vec <- rep(vec, nrow * ncol)
+    } else stopifnot("incompatible length" = length(vec) == nrow * ncol)
+
+    dim(vec) <- c(nrow, ncol)
+    stopifnot("lenght of colnames must be ncol" = is.null(colnames) || length(colnames) == ncol)
+    stopifnot("lenght of rownames must be nrow" = is.null(rownames) || length(rownames) == nrow)
+    dimnames(vec) <- list(rownames, colnames)
+    return(vec)
+}
+
+my_matrix(1:6)
+my_matrix(1:6, ncol=1)
+my_matrix(1:6, ncol=2)
+my_matrix(1:6, ncol=3)
+my_matrix(1:6, ncol=6)
+my_matrix(1:6, ncol=4)
+my_matrix(1:6, nrow=2)
+my_matrix(1:6, nrow=7)
+my_matrix(1:6, ncol=2, nrow=2)
+my_matrix(1:6, ncol=2, nrow=3)
+my_matrix(1:6, ncol=2, nrow=1)
+my_matrix(0, ncol=3, nrow=2)
+my_matrix(1:6, ncol=3, colnames=LETTERS[1:3])
+my_matrix(1:6, ncol=3, colnames=LETTERS[1:2])
+my_matrix(1:6, ncol=3, rownames=letters[24 + 1:2])
+my_matrix(1:6, ncol=3, colnames=LETTERS[1:3], rownames=letters[24 + 1:2])

sose2021/r/w02/P02-3-exerc.R

@@ -0,0 +1,22 @@
+my_tibble <- function(data) {
+    attr(data, "row.names") <- (1:lengths(data)[1])
+    attr(data, "class") <- c("tbl_df", "tbl", "data.frame")
+    return(data)
+}
+
+library(tibble)
+my_tb <- my_tibble(list(x=1:3, y=letters[1:3]))
+tb <- tibble(x=1:3 , y=letters[1:3])
+identical(tb, my_tb)
+
+my_factor <- function(data) {
+    lvls <- unique(data)
+    vec <- sapply(data, function(x) match(x, lvls), USE.NAMES=FALSE)
+    attr(vec, "levels") <- lvls
+    attr(vec, "class") <- "factor"
+    return(vec)
+}
+
+my_fac <- my_factor (c("a", "b", "a", "a", "c", "c"))
+fac <- factor(c("a", "b", "a", "a", "c", "c"))
+identical(fac, my_fac)

sose2021/r/w02/P02-4-exerc.R

@@ -0,0 +1,56 @@
+collatz <- function(raw_x, max_iter) {
+    stopifnot("Length of x must be 1" = length(raw_x) == 1)
+    x <- as.integer(raw_x)
+    stopifnot("Cannot interprete x as integer" = !is.na(x))
+    sequ <- c(x)
+    len <- NA
+    for (n in (1:(max_iter-1))) {
+        if (x == 1) {
+            len <- n
+            break
+        } else if (x %% 2 == 0) {
+            x <- x / 2
+        } else {
+            x <- 3*x+1
+        }
+        sequ <- c(sequ, x)
+    }
+    return(list(seq=sequ, len=len))
+}
+
+str(collatz(1, 1e4))
+## List of 2
+##  $ seq: int 1
+##  $ len: int 1
+str(collatz(2, 1e4))
+## List of 2
+##  $ seq: int [1:2] 2 1
+##  $ len: int 2
+str(collatz(3, 1e4))
+## List of 2
+##  $ seq: int [1:8] 3 10 5 16 8 4 2 1
+##  $ len: int 8
+str(collatz(3, 5))
+## List of 2
+##  $ seq: int [1:5] 3 10 5 16 8
+str(collatz("4", 1e4))
+## List of 2
+##  $ seq: int [1:3] 4 2 1
+##  $ len: int 3
+str(collatz("four", 1e4))
+## Warning in collatz("four", 10000): NAs introduced by coercion
+## Error in collatz("four", 10000): Cannot interprete x as integer
+str(collatz(1:5, 1e4))
+## Error in collatz(1:5, 10000): Length of x must be 1
+str(collatz(5.0, 1e4))
+## List of 2
+##  $ seq: int [1:6] 5 16 8 4 2 1
+##  $ len: int 6
+str(collatz(5.1, 1e4))
+## List of 2
+##  $ seq: int [1:6] 5 16 8 4 2 1
+##  $ len: int 6
+str(collatz(5.9, 1e4))
+## List of 2
+##  $ seq: int [1:6] 5 16 8 4 2 1
+##  $ len: int 6

sose2021/r/w03/P03-1.R

@@ -0,0 +1,8 @@
+# Josua Kugler, Christian Merten
+
+`%o%` <- function(f, g) {
+    comp <- function(...) {
+        return(f(g(...)))
+    }
+    return(comp)
+}

sose2021/r/w03/P03-2.R

@@ -0,0 +1,37 @@
+# Josua Kugler, Christian Merten
+
+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)

sose2021/r/w03/P03-3.R

@@ -0,0 +1,172 @@
+# Josua Kugler, Christian Merten
+
+## 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))
+    if (print_missing) {
+        apply(which(is.na(s), arr.ind=T), 1, function(x) cat("missing value at ", x[1], ",", x[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=""))
+    }
+    invisible(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)