diff --git a/sose2021/algebra/alg10.pdf b/sose2021/algebra/alg10.pdf new file mode 100644 index 0000000..a27de69 Binary files /dev/null and b/sose2021/algebra/alg10.pdf differ diff --git a/sose2021/algebra/alg10.xopp b/sose2021/algebra/alg10.xopp new file mode 100644 index 0000000..c71e1b1 Binary files /dev/null and b/sose2021/algebra/alg10.xopp differ diff --git a/sose2021/algebra/alg11.pdf b/sose2021/algebra/alg11.pdf new file mode 100644 index 0000000..c798c1b Binary files /dev/null and b/sose2021/algebra/alg11.pdf differ diff --git a/sose2021/algebra/alg11.xopp b/sose2021/algebra/alg11.xopp new file mode 100644 index 0000000..f567e08 Binary files /dev/null and b/sose2021/algebra/alg11.xopp differ diff --git a/sose2021/algebra/alg12.pdf b/sose2021/algebra/alg12.pdf new file mode 100644 index 0000000..1fc1d32 Binary files /dev/null and b/sose2021/algebra/alg12.pdf differ diff --git a/sose2021/algebra/alg12.xopp b/sose2021/algebra/alg12.xopp new file mode 100644 index 0000000..f1722b8 Binary files /dev/null and b/sose2021/algebra/alg12.xopp differ diff --git a/sose2021/algebra/alg8.pdf b/sose2021/algebra/alg8.pdf new file mode 100644 index 0000000..83fef06 Binary files /dev/null and b/sose2021/algebra/alg8.pdf differ diff --git a/sose2021/algebra/alg8.xopp b/sose2021/algebra/alg8.xopp new file mode 100644 index 0000000..00a28e6 Binary files /dev/null and b/sose2021/algebra/alg8.xopp differ diff --git a/sose2021/algebra/alg9.pdf b/sose2021/algebra/alg9.pdf new file mode 100644 index 0000000..7dac566 Binary files /dev/null and b/sose2021/algebra/alg9.pdf differ diff --git a/sose2021/algebra/alg9.xopp b/sose2021/algebra/alg9.xopp new file mode 100644 index 0000000..a88bcd7 Binary files /dev/null and b/sose2021/algebra/alg9.xopp differ diff --git a/sose2021/funktheo/funk10.pdf b/sose2021/funktheo/funk10.pdf new file mode 100644 index 0000000..cbe73d4 Binary files /dev/null and b/sose2021/funktheo/funk10.pdf differ diff --git a/sose2021/funktheo/funk10.xopp b/sose2021/funktheo/funk10.xopp new file mode 100644 index 0000000..05f3b1e Binary files /dev/null and b/sose2021/funktheo/funk10.xopp differ diff --git a/sose2021/funktheo/funk11.pdf b/sose2021/funktheo/funk11.pdf new file mode 100644 index 0000000..83ec431 Binary files /dev/null and b/sose2021/funktheo/funk11.pdf differ diff --git a/sose2021/funktheo/funk11.xopp b/sose2021/funktheo/funk11.xopp new file mode 100644 index 0000000..20380ca Binary files /dev/null and b/sose2021/funktheo/funk11.xopp differ diff --git a/sose2021/funktheo/funk12.pdf b/sose2021/funktheo/funk12.pdf new file mode 100644 index 0000000..08e53fe Binary files /dev/null and b/sose2021/funktheo/funk12.pdf differ diff --git a/sose2021/funktheo/funk12.xopp b/sose2021/funktheo/funk12.xopp new file mode 100644 index 0000000..a3dedcd Binary files /dev/null and b/sose2021/funktheo/funk12.xopp differ diff --git a/sose2021/funktheo/funk13.pdf b/sose2021/funktheo/funk13.pdf new file mode 100644 index 0000000..00ef9b2 Binary files /dev/null and b/sose2021/funktheo/funk13.pdf differ diff --git a/sose2021/funktheo/funk13.xopp b/sose2021/funktheo/funk13.xopp new file mode 100644 index 0000000..cd0c5e0 Binary files /dev/null and b/sose2021/funktheo/funk13.xopp differ diff --git a/sose2021/funktheo/funk7.pdf b/sose2021/funktheo/funk7.pdf index 8a535a6..e180ae1 100644 Binary files a/sose2021/funktheo/funk7.pdf and b/sose2021/funktheo/funk7.pdf differ diff --git a/sose2021/funktheo/funk7.xopp b/sose2021/funktheo/funk7.xopp index de2465c..1334047 100644 Binary files a/sose2021/funktheo/funk7.xopp and b/sose2021/funktheo/funk7.xopp differ diff --git a/sose2021/funktheo/funk8.pdf b/sose2021/funktheo/funk8.pdf new file mode 100644 index 0000000..7947329 Binary files /dev/null and b/sose2021/funktheo/funk8.pdf differ diff --git a/sose2021/funktheo/funk8.xopp b/sose2021/funktheo/funk8.xopp new file mode 100644 index 0000000..124d75d Binary files /dev/null and b/sose2021/funktheo/funk8.xopp differ diff --git a/sose2021/funktheo/funk9.pdf b/sose2021/funktheo/funk9.pdf new file mode 100644 index 0000000..5d97758 Binary files /dev/null and b/sose2021/funktheo/funk9.pdf differ diff --git a/sose2021/funktheo/funk9.xopp b/sose2021/funktheo/funk9.xopp new file mode 100644 index 0000000..0e4f07d Binary files /dev/null and b/sose2021/funktheo/funk9.xopp differ diff --git a/sose2021/r/rep/shorts.R b/sose2021/r/rep/shorts.R new file mode 100644 index 0000000..a4a7bd8 --- /dev/null +++ b/sose2021/r/rep/shorts.R @@ -0,0 +1,1335 @@ +library(tidyverse) +library(rlang) +library(sloop) # for OOP +library(nycflights13) # for examples + +flights2 <- flights %>% select(year:day, hour, tailnum, carrier, origin, dest) +airports2 <- airports %>% select(faa, name) +stocks <- tibble(year = sample(2011:2015, rep=T, 8), + qtr = sample(1:4, rep=T, 8), + return = c(1.88, 0.59, 0.35, NA, 0.92, NA, 2.66, 3.55)) %>% unique + +# definitionen + +students <- tibble( + name = c("Alice", "Bob", "Carl", "Dave", "Eve"), + grade = c(1, 2, 2, 3, 1) +) + +info <- tibble( + grade = 3:1, + desc = c("Poor", "Good", "Excellent"), + fail = c(T, F, F) +) + +# Sequenzen + +1:42 +0.5:-3.9 + +seq(0, 3, by=0.75) +seq(0.5, -3.9, len=5) + +rep(c(0,2), times=5) +rep(c(0,2), each=5) + +cumsum(1:10) + +# Indexing + +x <- 21:42 + +x[c(3, 7, 6, 7.9)] # position +x[-c(1, 3, 5)] # ausschluss von angegebenen positionen + +x[FALSE] # integer(0) + +seq_along(x[FALSE]) # zuverlässiger +1:length(x[FALSE]) + +x[] # nichts: alles wird zurückgegeben +x[x %% 2 == 0] # wahrheitswerte +x[(seq_along(x)-1) %% 5 == 0] +x[c(T, F)] # jedes zweite, da T, F recycled wird + +y <- structure(x, names=letters[seq_along(x)]) + +y[c("a", "j", "e", "e", "z")] # namen +y[setdiff(names(y), c("a", "e", "z"))] # analogon zu negativen zahlen + +m <- outer(1:5, 1:4, paste, sep=",") +m[2:7] # indizierung auf zugrundeliegendem vektor +m[c(4,3), c(1,4,3)] # indizierung nach dimensionen + +m[1,, drop=FALSE] # dimensionsvereinfachung verhindern + +select <- rbind( + c(1, 1), + c(3, 1), + c(2, 4) +) + +m[select] # matrix: jede zeile gibt eine koordinatenkombination an + +m <- matrix(1:9, nrow=3) + +which(m %% 2 == 0, arr.ind=F) # gibt koordinaten der TRUE values +arrayInd(which(m %% 2 == 0), dim(m)) # wandelt vektor koordinaten in koordinatenmatrix um + +## tibbles + +tb <- tibble(x = 1:3, y = 3:1, z = letters[1:3]) + +tb[tb$x == 2, ] # wie bei matrizen +tb[c("x", "z")] # wie bei listen, gibt spalten x und z +tb[tb$x == 2, "z", drop=T] # drop um tibble struktur zu vergessen + +## Einzelne Elemente + +x <- list(bla=1:3, blub=list("fritz", "hans"), 4:6) +x[1] # liste mit einem element +x[[1]] # element der liste + +x[[c(2, 1)]] # verschachtelte indizierung +x[["blub"]][[1]] # das selbe + +x <- 1:10 +x[[3]] # geht auch fuer atomare vektoren +m[[2, 3]] # bei arrays mit entsprechenden dimensionen + +key <- "bla" +x$bla +x[[key]] + +options(warnPartialMatchDollar=T) +x$blu # partial matching von "blub" + +## Fehlende Indizes + +x <- 1:3 +x[4] # NA +x[[4]] # Error + +lst <- as.list(x) + +lst[4] # NA +lst[[4]] # Error + +names(x) <- letters[1:3] +names(lst) <- letters[1:3] + +x[["d"]] # Error, ABER: +lst[["d"]] # NULL +lst$d # NULL + +## assignment + +x <- 1:5 +x[c(1, 2, NA)] <- c(1,2) # Error +x[c(1, 2, NA)] <- 1 # funktioniert + +lst <- list(abc=1) + +lst$ab # partial matching +lst$ab <- 2 # kein partial matching, neuer eintrag + +x <- 1:9 +x[1:6] <- 11:13 # recycling + +x <- 7 +x[1e5] <- 5 # funktioniert, out of bound assignment vergroessert vektor + +tb <- tibble(x=2^(1:4), y=c("1.2", "2.3", "3.4", "4.2")) +tb[] <- lapply(tb, as.integer) # erhaelt tibble struktur, weil subsetting assignment + +lst["abc"] <- NULL # element aus liste entfernen +lst["ab"] <- list(NULL) # NULL liste einfügen + +## helpers for indexing + +### match and merge + +id <- match(students$grade, info$grade) # find index of entries in students$grade in info$grade +cbind(students, info[id, -1]) + +merge(students, info, by.x="grade", by.y="grade") # kurzform + +### sorting + +x <- runif(100, min=-40, max=52) +order(x) # x[order(x)] = sort(x) +sort(x) # sortiert +rank(x) # ranked alle elemente aufsteigend + +students[order(students$grade), ] # sortiere nach noten + +# Missing values + +## NULL +c() # NULL +c(typeof(NULL), length(NULL)) # NULL, 0 + +## BASE_TYPE(0) +c(typeof(integer(0)), length(integer(0))) + +## NA... +c(typeof(NA_integer_), length(NA)) # laenge 1 und entsprechenden typ + +## indexing +x <- 1:3 + +x[0] +x[NULL] + +x[] + +x[NA] + +x[NA_integer_] + +## pruefen + +x <- list(1, NA, NaN, NA_real_, NA_integer_, NA_character_) + +is.na(x) +is.null(x) + +is.nan(NaN) + +## vergleich +1:3 == NA +NA == NA +identical(NA, NA) +NULL == NULL +identical(NULL, NULL) + +# Plots + +x <- seq(-3, 3, len=100) +plot(x, sin(x), + type="l", + main="Titel", + xlab="x-Achse", + ylab="y-Achse", + xlim=c(-2, 2), + ylim=c(-1, 1), + lwd=3, + lty=2, + col="cyan") +points(x, sin(x), pch=3, col="red") + +hist(rnorm(1000)) +barplot(1:5) + +x <- seq(0, 1, len=100) +y <- seq(0, pi, len=100) +f <- function(x,y) x^2 - sin(y) +outer(x,y,f) +contour(x,y,outer(x,y,f)) + +# Randomness + +## random deviates + +set.seed(42) + +rnorm(8, mean=12, sd=3) +rbinom(42, size=13, prob=0.45) +runif(10, min=-13, max=26) + +# Printing + +print(1:10) + +cat("3 + 5 ist", 3+5, "\n", sep=" ") +paste("3 + 5 ist", 3+5, "\n", sep=" ") + +as.character(pi) + +sprintf("Eine Zufallszahl aus der %s ist %.2f.", "Normalverteilung", rnorm(1)) + +# Listen +lst <- list(1:3, + "a", + c(T, F, T), + runif(10), + list(1, "b"), + sum) +identical(lst[[c(5,2)]], "b") +str(lst) +c(typeof(lst), class(lst), length(lst)) + +is.vector(lst) +is.list(lst) + +unlist(list(1:10)) +as.list(1:10) + +lst[2] +lst[[2]] +lst[[2]] <- NULL +lst[1] <- list(NULL) + +str(c(list(), letters[1:5], 42)) + +# Matrizen + +n <- 1e3 +m1 <- matrix(rnorm(n^2), nrow=n) +m2 <- matrix(rnorm(n^2), nrow=n) + +m <- matrix(1:16, nrow=4, byrow=F) +m[2,2] <- 0 +m[1,1] <- 0 + +dim(m) +length(m) +nrow(m) +ncol(m) +rowSums(m) +colSums(m) +det(m) + +r <- sample(4) +y <- solve(m, r) +m %*% y + +solve(m) # inverse +qr(m) # qr zerlegung +chol(m) # cholesky zerlegung +svd(m) # singulaerwertzerlegung +eigen(m) # eigenwerte und vektoren + +m1 + m2 +m1 * m2 # elementweise mult +m1 %*% m2 # matrix mult +t(m1) # transpose +aperm(m1) # auf arrays verallgemeinert + +cbind(m, 1:4) +rbind(m, 1:4) + +## allgemeiner + +x <- 1:6 +attr(x, "dim") <- c(2,3) +dim(x) <- c(2,3,1) +array(1:16, dim=c(2,2,2)) + +matrix(list("a", 1, T, list()), + nrow=2, + dimnames=list(Zeilen=NULL, Spalten=c("hi", "fritz"))) +rownames(x) <- letters[1:2] +colnames(x) <- LETTERS[1:3] + +NROW(1:12) == nrow(matrix(1:12)) # aber nrow(1:12) ist NULL + +# Tibbles + +tb <- tibble(x=1:3, y=letters[1:3]) + +as_tibble %$% list(x=1:3, y=letters[1:3]) +as_tibble %$% matrix(1:4, ncol=2, dimnames=list(NULL, c("A", "B"))) + +add_column(tb, z=-1:1, w = 0) +add_row(tb, x=4:5, y=letters[4:5], .before=2) + +head(tb, 2) +tail(tb, 1) + +dplyr::bind_rows(tb, tibble(x=42:45, y="E")) +dplyr::bind_cols(tb, tibble(e=42:44, d="E")) + +options(tibble.print_min=6, # makes output more compact + tibble.print_max=6, + tibble.max_etra_cols=0) + +readr::read_csv("bla.csv") + +## dplyr verbes + +filter(flights, (arr_delay - dep_delay) < -60, dep_delay > 30) # zeilen filtern + +arrange(flights, desc(dep_delay)) # zeilen sortieren + +nms <- c("month", "year") +select(flights, 5, 5, carrier, "origin", arr_time:flight, -flight, + all_of(nms), -any_of(nms)) # position select +select(flights, # condition select + where(is.character) | contains("delay"), + fritz = ends_with("delay"), + -starts_with("dep_"), + tag = contains("day"), # no regex + matches("^y"), # regex + everything()) # alle restlichen spalten (umsortierung) + +rename(flights, monat = month, tag = day) + +mutate(airlines, name_length = nchar(name), carrier=NULL) +transmute(flights, carrier, gain = dep_delay - arr_delay) + +summarize(flights, total_delay = sum(abs(dep_delay), na.rm = T), + delay_range = range(dep_delay, na.rm = T), + count_origin = n_distinct(origin)) + +count(flights, year, month, day, origin, sort=T) # group by variables and summarize n() + +group_by(flights, month) %>% summarize(delay_mean = mean(dep_delay, na.rm=T)) + +group_by(flights, month, carrier, dep_time) %>% select(group_cols()) + +group_by(flights, carrier) %>% filter(sum(distance, na.rm = T) > 5e7) + +group_by(flights, carrier) %>% mutate(prop = distance / sum(distance, na.rm=T)) + +summarize(flights, + across(where(is.numeric) & !(year | month | day | hour), + list(min = min,max = max,mean=mean), + na.rm = T, + .names = "{fn}.{col}")) + +mutate(flights, across(dep_time:arr_delay, partial(`*`, 2))) + +filter(flights, across(where(is.numeric) & !flight & !year, partial(`>`, 700) %.% abs)) + +rowwise(flights) %>% mutate(m = mean(c_across(dep_time:arr_time)), .keep="used") # vermeiden + +## non standard evaluation austricksen + +tobefiltered <- "dep_delay" +filter(flights, .data[[tobefiltered]] > +120) + +## join und co. + +left_join(flights2, airports2, by=c("origin" = "faa")) %>% + left_join(airports2, by=c("dest" = "faa"), suffix=c("_origin", "_dest")) + +right_join(flights2, airports2, by=c("dest" = "faa")) # priorisiert rechts +inner_join(flights2, airports2, by=c("dest" = "faa")) # keins na +full_join(flights2, airports2, by=c("dest" = "faa")) # egal + +top_dest <- count(flights, dest, sort=T) %>% head(10) +semi_join(flights, top_dest) # only keep rows that join with row in top_dest +anti_join(flights, top_dest) # only keep rows that DO NOT join with row in top dest + +## tidy tables + +pivot_longer(table4a, cols=where(is.numeric), names_to="year", values_to="cases") + +pivot_wider(table2, names_from=type, values_from=count) + +separate(table3, rate, into = c("cases", "population"), sep = "/", convert = T) + +extract(table3, rate, into = c("cases", "population"), regex = "^(.*?)/(.*?)$", convert = T) + +unite(table5, "year", century, year, sep="") %>% mutate(year = as.integer(year)) + +## fix missing values + +complete(stocks, year, qtr) # make implicit missing values explicit + +drop_na(stocks) + +replace_na(stocks, list(return = 42)) + +mutate(stocks, return = na_if(return, "my custom na")) + +# Apply und co. + +f <- function(x) sprintf("a random number is %.2f which is %.3f probable", x, pnorm(x)) + +lapply(rnorm(100), f) + +sapply(rnorm(100), f) +simplify2array(lapply(rnorm(100), f)) + +replicate(5, runif(10), simplify = TRUE) + +mapply(`+`, 1:100, 1:100) + +m <- matrix(1:12, nrow=3) +dimnames(m) <- list(cols=NULL, rows=NULL) +apply(m, 1, mean) + +a <- array(1:24, dim=2:4, dimnames=list(x1=NULL, x2=NULL, x3=NULL)) +apply(a, c(1,2), range) + +outer(1:3, 1:5, `*`) + +funs <- list(mean=mean, median=median, var=var) +X <- replicate(5, runif(sample(20, 1)), simplify=F) + +outer(X, funs, function(x_list, f_list) mapply(function(f, x) f(x), f_list, x_list)) + +## mathematische funktionale + +integrate(sin, 0, pi) + +optimize(sin, c(0, 2*pi), maximum=T) + +x <- seq(0, 2*pi, len=10) +f_lin <- approxfun(x, sin(x)) +f_cub <- splinefun(x, sin(x)) + +## funktionsoperatoren + +fib <- function(n) { + if (n<2) return(1) + fib(n-2) + fib(n-1) +} + +fib <- memoise::memoise(fib) + +capture.output(print("hi")) + +sample2 <- Vectorize(sample, "size") + +# types + +sapply(list(NULL, + TRUE, # -- basetypes -- + 1L, + 1, + "", + raw(3), + 1+3i, # ^^ basetypes ^^ + list(), + expr(a), + expr(1+2), + expression(1+2), + env(), + mean, + sin, + `[`), + typeof) %>% unique() + +sapply(list(NULL, + TRUE, # -- basetypes -- + 1L, + 1, + "", + raw(3), + 1+3i, # ^^ basetypes ^^ + list(), + expr(a), + expr(1+2), + expression(1+2), + env(), + mean, + tibble(), # tidyverse + data.frame(), + matrix(), + array(), + factor(), + Sys.Date(), + Sys.time(), + proc.time()), + class) %>% unique() + +## basetypes +misc <- list(T, 1:3, pi, "hi", 1+3i, raw(4)) +sapply(misc, typeof) + +is.numeric(c(0.3, 3)) # TRUE +is.integer(0.3) # FALSE + +is.atomic(list()) # FALSE + +str(list(logical(3), integer(3), double(3), character(3), complex(3), raw(3))) + +### integer + +c(42L, NA_integer_, 1:3, .Machine$integer.max) + +### double +c(3, 4.2, pi, 1e4, .Machine$xmax, Inf, NaN, NA_real_) + +c(1/0, -1/0, 0/0, 1/Inf) + +# numeric synonym zu double in class(), as_numeric(), numeric(n), print(), str() +# ABER: +is.numeric(1L) # TRUE + +# Not available type fuer double ist: +NA_real_ + +### character + +"bla 'einca' asdf" +cat('asdf "as" asdf \\ hi\n') +x <- c("ä", "Hallo", "", NA_character_, "\n") +nchar(x) +cat(r"(\n \ )", "\n") + +letters +LETTERS +month.name +month.abb + +## coercion + +as.double("2.2") +c(TRUE, 15) +c(TRUE, 1L, 1, "eins") +c(c(TRUE, 1L), 1, "eins") + +# attributes + +x <- seq(-2, 3, len=42) + +attr(x, "asdf") <- c(1,2) +structure(x, "asdf" = c(1,2)) +attributes(x)$asdf <- c(1,2) # geht auch wenn x <- NULL + +attr(x, "asdf") +attributes(x)$asdf + +identical(x, seq(-2, 3, len=42)) + +## names + +x <- 1:4 +attr(x, "names") <- letters[1:4] +names(x) <- letters[1:4] +x <- c("a"=1, "b"=2, "c"=3, "d"=4) + +unname(x) # does not modify x +names(x) <- NULL # modifies x + +# S3 Objekte / Klassen + +x <- runif(100) +attr(x, "class") <- "Toller Hecht" +class(x) <- "Toller Hecht" + +unclass(x) # does not modify x +class(x) <- NULL # modifies x + +## implizite klassen +# falls class nicht gesetzt -> implizite klasse: matrix, array, function, numeric oder typeof(x) + +## spezielle S3 Objekte + +### factors +# integer vektoren mit class = factor und attribut levels + +x <- sample(13, 100, rep=T) +x_factor <- factor(letters[x*2]) + +typeof(x_factor) # integer +class(x_factor) # factor +str(attributes(x_factor)) # levels + +table(x_factor) # summarize factor + +x_factor[c(3,7), drop = TRUE] # wegwerfen der anderen level + +### Date +# double vektoren mit class = Date + +Sys.Date() +str(attributes(Sys.Date())) + +unclass(Sys.Date()) # anzahl tage seit 1.1.1970 + +### POSIXct +# double vektoren mit class = c(POSIXct, POSIXt) + +Sys.time() +str(attributes(Sys.time())) + +unclass(Sys.time()) # anzahl sekunden seit 1.1.1970 + +### proc_time +# double vektor der länge 5 mit class = proc_time + +proc.time() +str(attributes(proc.time())) # in sekunden, genauer: +# user: beanspruchung der CPU durch R +# system: beanspruchung der CPU durch betriebssystem im auftrag von R +# elapsed: gesamt + +str(unclass(proc.time())) + +system.time({ + data <- runif(1e6) + stats <- c(mean(data), var(data)) +}) # gibt auch proc_time objekt + +### tibble +# data.frame mit class = c(tbl_df, tbl). ein data.frame ist wiederum eine liste seiner spalten + +tb <- tibble(x = 1:3, y = letters[3:1]) +str(attributes(tb)) +typeof(tb) + +str(unclass(tb)) + +tb$x +tb$z <- matrix(1:15, nrow=3) # kann matrizen +tb$e <- tibble(a=sample(100, 3), b=rnorm(3)) # und tibbles + +as_tibble(as.matrix(tb[,-2])) + +# funktionen + +## pipe + +pi %>% `*`(2,.) %>% sin %>% abs %>% `<`(., 1e-14) -> res + +## eigene operatoren + +`%.%` <- function(f, g) function(...) f(g(...)) +`%$%` <- function(f, x) f(x) +flip <- function(f) function(x, y) f(y, x) + +str %.% attributes %$% tibble (a = sample(100, 3), b = rnorm(3)) + +## ersetzungsfunktionen + +`modify<-` <- function(x, position, value) { + x[position] <- value + x +} + +x <- 1:10 +modify(x, 3) <- 42L + +modify(names(x), 3) <- "hi" + +## do.call + +do.call(mean, list(x=sample(100), na.rm=T)) + +## funktionstypen +# funktionen haben class = function, aber + +c(typeof(mean), typeof(sum), typeof(`[`)) # builtin und special sind primitive, alle anderen closure + +f <- function(x) { + # kommentar + 10 +} +formals(f) +body(f) +environment(f) + +formals(args(sum)) # argument liste primitiver funktionen + +## lazy evaluation + +f(stop("hi")) # argument wird nicht ausgewertet + +## default arguments + +f <- function(x = y*2, y = 1, z = a+b, e=ls()) { # defaults refer to other arguments + a <- 10 + b <- 100 + print(e) + cat(sprintf("missing x: %s, missing y: %s\n", missing(x), missing(y))) + c(x, y, z) +} +f(x=3, e=ls()) # ls is evaluated in caller env +f() # ls is evaluated in execution env + +## dot-dot-dot + +f <- function(x, ...) { # potentially infinite additional parameters + str(list(first = ..1, third = ..3)) # access additional parameters + mean(unlist(list(...))) +} +f(1,2,3,42) + +## return values + +invisible(42) # hide return value + +f <- function(x) { + print("Hello") + on.exit(print(1)) + on.exit(print(2), add = TRUE, after = FALSE) + if (x) return(10) else stop("Error") + print("Well...") +} + +f(TRUE) +f(FALSE) + +# strings + +## basics + +str_length(c("a", "abs", NA, "")) + +str_c("prefix", LETTERS[sample(26, 3, rep=T)], "suffix", # vektorisiert in allen args + sep = "-", + collapse = " * ") + +x <- "Fritz Walter ist toll. " +str_sub(x, start=3, end=5) +str_sub(x, end=-5) # only drop last 4 chars +str_sub(x, start=7, end=12) <- "Hasl" + +str_trim(x) # remove whitespace in beginning and end + +str_squish(x) # remove repeated whitespace inside + +str_to_upper(x) + +str_to_lower(x) + +str_to_title(x) + +str_dup(c("a", "bB"), 2:5) + +## formatting + +str_glue("3 * pi = {format(3*pi, digits=3)} und das ist {'{toll}'}, weil {x}.") # auch vektorisiert + +str_glue_data(tibble(x=1:3, y=letters[1:3]), "Es ist x={x} <-> y={y}") + +## regex + +str_detect(x, "[aeiou]") # alles vektorisiert + +str_subset(letters, "[aeiou]") # recycling + +str_which(letters, "[aeiou]") + +str_count(letters, letters[1:13]) + +str_extract(c(x, "Stopp"), ".t") +str_extract_all(c(x, "Stopp"), ".t") + +str_locate(c(x, "Stopp"), ".t") +str_locate_all(c(x, "Stopp"), ".t") + +str_split(c("Kaffee,Klettern_Sport.Wald", "Bla.Furz"), "[,_\\.]") +str_split("Fritz.kann.kochen", fixed(".K", ignore_case=T)) + +str_match("Fritz.kann.kochen", "(.)\\.(.)") # gibt gruppen aus +str_match_all("Fritz.kann.kochen", "(.)\\.(.)") + +str_replace("Fritz.kann.kochen", "(.)\\.(.)", "\\2$\\1") # use \1.. in replacement to access groups +str_replace_all("Fritz.kann.kochen", "(.)\\.(.)", "\\2$\\1") + +# environments + +e1 <- env(a = FALSE, b = "a", c = 2.3, d = 1:3) +c(class(e1), typeof(e1), length(e1)) + +e2 <- e1 # environments werden per referenz uebergeben +e2$a = T +e1$a +identical(e1, e2) +e1$d <- e1 + +## env infos + +env_print(e1) + +env_names(e1) +env_names(empty_env()) # leere umgebung +env_names(global_env()) # globale umgebung (konsole) + +env_label(global_env()) +env_label(e1) +env_label(current_env()) # aktuelle umgebung + +e2 <- env(e1, z = 42) +env_parent(e1) +env_parent(e2) +env_parent(empty_env()) # error, leere umgebung hat kein parent + +env_parents(e1) +env_parents(e2) + +## manipulate environments + +env_bind(e1, z=69, asdf="fritz") + +env_get(e2, "b", inherit=T) # inherit = T search in parent env if not found here + +str(env_get_list(e1, c("a", "b", "d"))) + +env_has(e2, c("b", "z"), inherit=F) + +env_unbind(e2, c("b", "z")) + +## function environments + +a <- 42 +f <- function(x) x + a + +env_label(current_env()) +env_label(fn_env(f)) +fn_env(f) <- e1 + +g <- function(x) { + print(env_label(current_env())) + function(y) x+y +} + +h <- g(3) + +## lazy evaluation + +x <- 1 +y <- 2 +env_bind_lazy(current_env(), v = c(x,y)) # creates promise v pointing to c(x,y) +x <- 5 +v + +# OOP + +# sloop inspectino + +otype(tibble(x=1:3, y=3:1)) + +s3_class(matrix(1:10, nrow=2)) + +ftype(print) +ftype(apply) + +s3_methods_generic("elapse_time") + +inherits(tibble(x=1:12), "tbl_df") + +s3_dispatch(print(tibble(x=1:12))) + +## S3 + +tyrion <- structure(list(name = "Tyrion", age = 42), class = c("Noble", "Person")) + +print.Person <- function(p) cat(str_glue("{p$name} ({p$age})"), "\n") + +elapse_time <- function(obj, time) { # generic function + UseMethod("elapse_time") +} + +elapse_time.Person <- function(p, time) { # implementierte methode + p$age <- p$age + time + p +} + +elapse_time.default <- function(o, t) { + stop(str_glue("Cannot elapse time for object of class {class(o)}.")) +} + +elapse_time.Noble <- function(p, time) { + cat("A noble person does not age\n") # actually wrong + NextMethod() # go to next method in dispatch list +} + +### constructor helpers + +new_Person <- function(x, subclass = NULL) { + stopifnot("Person must be a list" = is.list(x)) + structure(x, class=c(subclass, "Person")) +} + +new_Noble <- function(x, subclass = NULL) { + new_Person(x, subclass=c(subclass, "Noble")) +} + +validate_Person <- function(p) { + if(!inherits(p, "Person")) stop("Object must inherit Person") + invisible(p) +} + +Person <- function(name, age) { + p <- new_Person(list(name = name, age = age)) + validate_Person(p) + p +} + +### coercion + +as_Person <- function(x, ...) UseMethod("as_Person") +as_Person.Person <- `(` +as_Person.character <- function(name, age) Person(name, age) + +### internal generics + +c.numeric <- function(...) return("c: numeric") +c(42) # does not use c.numeric because class is implicit +c(structure(42, class="numeric")) + +### group generics + +units <- c(kg = 1, g = 1e-3, mg = 1e-6) + +m <- structure(1:12, class="Mass", unit="kg") +m2 <- structure(350, class="Mass", unit="g") + +print.Mass <- function(x) print(str_glue("{x} {attr(x, 'unit')}")) + +Summary.Mass <- function(x, ...) { + m <- NextMethod() + structure(m, class="Mass", unit=attr(x, "unit")) +} + +### double dispatch + +`+.Person` <- function(x, y) print("+ on person") + +`+.Mass` <- function(x, y) { + a <- unclass(x) + b <- unclass(y) + structure(a * units[[attr(x, "unit")]] + b * units[[attr(y, "unit")]], class="Mass", + unit = "kg") +} + +m + m2 +m + tyrion # error because of incompatible methods +m + 1 # error in +.Mass + +## S4 + +.Person <- setClass("Person", slots = c(name = "character", age = "numeric")) +.Employee <- setClass("Employee", contains = "Person", slots = c(boss = "Person")) + +Person <- function(name, age) { + stopifnot(length(name) == 1 && length(age)) + .Person(name = name, age = age) +} + +Employee <- function(name, age, boss) { + p <- Person(name = name, age = age) + .Employee(p, boss = boss) +} + +tyrion <- Person(name = "Tyrion", age = 42) +peter <- Employee(name = "Peter", age = 13, boss = tyrion) + +tyrion@age <- tyrion@age + 1 +tyrion@name <- 42 + +slotNames(tyrion) + +is(tyrion) +is(peter, "Person") + +typeof(tyrion) +class(tyrion) + +### generics + +setGeneric("laugh", function(x) standardGeneric("laugh")) + +setMethod("laugh", "Person", function(x) { + cat(str_glue("{x@name} laughs out loudly."), "\n") +}) +setMethod("laugh", "Employee", function(x) { + cat(str_glue("{x@name} laughs out shyly."), "\n") +}) + +formals(getGeneric("show")) + +setMethod("show", "Person", function(object) { + cat(str_glue("{object@name} ({object@age})"), "\n") +}) +setMethod("show", "Employee", function(object) { + cat(str_glue("{object@name} ({object@age}) an Employee"), "\n") +}) + +### getters and setters + +setGeneric("name", function(x) standardGeneric("name")) +setMethod("name", "Person", function(x) x@name) +setGeneric("name<-", function(x, value) standardGeneric("name<-")) +setMethod("name<-", "Person", function(x, value) { + x@name <- value + x +}) + +### coercion + +as(peter, "Person") # default +emp <- as(tyrion, "Employee") # default +emp@boss + +setAs("Person", "Employee", function(from) { + stop("Can not coerce a Person to an Employee") +}) + +### introspection + +s4_methods_generic("laugh") + +s4_methods_class("Person") + +### inheriting S3 classes + +RangedNumeric <- setClass( + "RangedNumeric", + contains = "numeric", + slots = c(min = "numeric", max = "numeric") +) + +rn <- RangedNumeric(1:10, min=1, max=10) +rn@.Data # access underlying S3 or implicite class + +# meta programming + +## basics + +x <- expr(3+5*y) +y <- 12 +eval(x) + +str(exprs(name = 1+2, f(x), sin(42))) +typeof(expr(1)) + +c(typeof(expr(variable)), class(expr(variable))) # symbol name +c(typeof(expr(sin(x))), class(expr(sin(x)))) # language call + +lobstr::ast(f(g(x, h(), 1), x)) +a <- expr(f(g(x, h(), 1), x)) +str(as.list(a)) +a[[2]][[3]][[1]] +a[[c(2,3,1)]] <- expr(q) + +expr_text(a) + +identical(parse_expr("f(g(x, q(), 1), x)"), a) + +parse_exprs("x <- 4\nprint(x+5)") # parse multiple expressions as expr list + +## arguments + +f <- function(x, ...) { + print(enexpr(x)) # does not use promise + force(x) + print(enexpr(x)) + enexprs(...) +} +f(3+4, sin(pi), 0/0) + +## evaluation + +x <- y <- 3 +eval(expr(x+y), envir = env(`+` = `-`)) + +## quosures + +f <- function() { + x <- 10 + quo(1+x) +} +x <- 100 +q <- f() + +eval(quo_get_expr(q)) # evaluates in current environment +eval_tidy(q) # evaluates in captured environment + +expr_text(quo(1+2)) # prints weird ~ in front +quo_text(quo(1+2)) + +foo <- function(x, y) { + z <- 1 + x <- enexpr(x) + y <- enquo(y) + c(eval(x), eval_tidy(y)) +} +z <- 100 +foo(z*2, z*2) # 2 200 (x is evaluated in execution env of foo, y is evaluated in global env) + +eval_tidy(expr(a <- 42)) # does not actually assign +eval(expr(a <- 42)) # does assign + +x <- 1 +eval_tidy(quo(x+y), list(y = 100)) + +## tidy eval framework + +### bang bang + +a <- expr(f(x)) +expr(1 + !!a) # Bang-Bang Operator + +lobstr::ast(expr(f(x))) +lobstr::ast(!!expr(f(x))) + +### big bang +x <- 1:3 +str(exprs(!!x)) +str(exprs(!!!x)) # big bang + +### walrus +name <- "asdf" +tibble(!!name := 1:5) + +### pronouns + +y <- 4 +tb <- tibble(x = 1:3, y=3:1) +eval_tidy(quo(.data$y + .env$y*10), tb) # .data datamask, .env environment + +### geschachtelte quosures + +x <- 1 +lobstr::ast(7 + !!(x+2)) +lobstr::ast(7 + !!quo(x+2)) # unwraps quosure and puts it in main quosure + +y <- 1 +create_q <- function() { + y <- 10 + quo(y) +} +qu <- create_q() +eval_tidy(quo(y + !!qu)) + +## applications + +var <- quo(y) +tb <- tibble(x=1:5, y = 5:1) +eval_tidy(quo(!!var == 4), tb) + +var <- "y" +eval_tidy(quo(.data[[var]] == 4), tb) + +mysummarise <- function(tb, mean_var, ...) { + qg <- enquos(...) + qm <- enquo(mean_var) + mean_name <- str_glue("mean_{quo_name(qm)}") + tb %>% + group_by(!!!qg) %>% + summarise(!!mean_name := mean(!!qm)) +} + +filterx <- function(var) { + filter2(tb, {{var}} == 1) +} + +source2 <- function(path) { + l <- readLines(path) + exs <- lapply(l, parse_expr) + model <- env(base_env()) + for (ex in exs) + res <- eval_tidy(ex, model) + res +} +source2("test.R") + +namedlist <- function(...) { + qs <- enquos(...) + l <- list(...) + names(l) <- lapply(qs, quo_text) + l +} +namedlist(letters, 1:10) + +filter2 <- function(tb, ex) { + ex <- enquo(ex) + tb[eval_tidy(ex, tb), ] +} + +mkInfix <- function(f) { + f <- enexpr(f) + e <- caller_env() + name <- expr_text(f) + e[[str_glue("%{name}%")]] <- eval(f) +} + +`%->%` <- function(x, y) { + y <- enexpr(y) + e <- caller_env() + e[[expr_text(y)]] <- x + invisible(x) +} + +# conditions + +stop("Error!") +stopifnot("Error!" = 3 == 4) + +warning("Warning!") +warnings() +last.warning + +message("Message!") + +{ + try(stop("hi"), silent = FALSE) + print("hallo") +} + +suppressWarnings({warning("warn"); message("msg")}) +suppressMessages({warning("warn"); message("msg")}) + +tryCatch( + message = msgHandler, + warning = warnHandler, + error = errorHandler, + expr = { + + } +) + +withCallingHandlers( + message = msgHandler, + warning = warnHandler, + error = errorHandler, + expr = { + + } +) + +outerVec <- function(a, b, f) { + res <- array(0, c(length(a), length(b), length(f(a[[1]], b[[1]])))) + for (i in seq_along(a)) { + for (j in seq_along(b)) { + res[i,j,] <- f(a[[i]], b[[j]]) + } + } + res +} +outerVec(1:5, 1:5, function(x, y) c(x,y)) + +cons <- function(h, t) function(x) if(x) h else t +`%:%` <- function(h, t) cons(h, t) + +itake <- function(x, k) { + res <- c() + for (i in 1:k) { + res <- c(res, ihead(x)) + x <- itail(x) + } + res +} + +itail <- function(x) if(is.null(x)) NULL else x(F) +ihead <- function(x) if(is.null(x)) NULL else x(T) +nocons <- function(t) function(x) if(x) ihead(t) else itail(t) + +izip <- function(f, x, y) { + cons(f(ihead(x), ihead(y)), izip(f, itail(x), itail(y))) +} +iapply <- function(x, f) f(ihead(x)) %:% iapply(itail(x), f) +ifilter <- function(x, pred) { + if(pred(ihead(x))) { + ihead(x) %:% ifilter(itail(x), pred) + } else { + nocons(ifilter(itail(x), pred)) + } +} + +ifold <- function(xs, f, acc) { + ifold(itail(xs), f, f(ihead(xs), acc)) +} + +fibs <- 1 %:% (1 %:% izip(`+`, fibs, itail(fibs))) +seq1 <- cons(1, seq1) +ns <- 1 %:% izip(`+`, seq1, ns) +iseq <- function(a, b=NULL, by=1) { + d <- cons(by, d) + res <- a %:% izip(`+`, d, res) + if (is.null(b)) return(res) + ifilter(res, function(x) x <= b) +} + +mk_primes <- function(xs) { + ihead(xs) %:% mk_primes(ifilter(itail(xs), function(a) a %% ihead(xs) != 0)) +} +primes <- mk_primes(itail(ns)) diff --git a/sose2021/tut-ana/praesenz-10.pdf b/sose2021/tut-ana/praesenz-10.pdf new file mode 100644 index 0000000..0ef8c07 Binary files /dev/null and b/sose2021/tut-ana/praesenz-10.pdf differ diff --git a/sose2021/tut-ana/praesenz-10.xopp b/sose2021/tut-ana/praesenz-10.xopp new file mode 100644 index 0000000..50c520c Binary files /dev/null and b/sose2021/tut-ana/praesenz-10.xopp differ diff --git a/sose2021/tut-ana/praesenz-11.pdf b/sose2021/tut-ana/praesenz-11.pdf new file mode 100644 index 0000000..cbb9149 Binary files /dev/null and b/sose2021/tut-ana/praesenz-11.pdf differ diff --git a/sose2021/tut-ana/praesenz-11.xopp b/sose2021/tut-ana/praesenz-11.xopp new file mode 100644 index 0000000..441b599 Binary files /dev/null and b/sose2021/tut-ana/praesenz-11.xopp differ diff --git a/sose2021/tut-ana/praesenz-12.pdf b/sose2021/tut-ana/praesenz-12.pdf new file mode 100644 index 0000000..eb63667 Binary files /dev/null and b/sose2021/tut-ana/praesenz-12.pdf differ diff --git a/sose2021/tut-ana/praesenz-12.xopp b/sose2021/tut-ana/praesenz-12.xopp new file mode 100644 index 0000000..be5117a Binary files /dev/null and b/sose2021/tut-ana/praesenz-12.xopp differ diff --git a/sose2021/tut-ana/praesenz-8.pdf b/sose2021/tut-ana/praesenz-8.pdf new file mode 100644 index 0000000..ac4d3bd Binary files /dev/null and b/sose2021/tut-ana/praesenz-8.pdf differ diff --git a/sose2021/tut-ana/praesenz-8.xopp b/sose2021/tut-ana/praesenz-8.xopp new file mode 100644 index 0000000..d6a19a9 Binary files /dev/null and b/sose2021/tut-ana/praesenz-8.xopp differ diff --git a/sose2021/tut-ana/praesenz-9.pdf b/sose2021/tut-ana/praesenz-9.pdf new file mode 100644 index 0000000..8efb7cf Binary files /dev/null and b/sose2021/tut-ana/praesenz-9.pdf differ diff --git a/sose2021/tut-ana/praesenz-9.xopp b/sose2021/tut-ana/praesenz-9.xopp new file mode 100644 index 0000000..88b756e Binary files /dev/null and b/sose2021/tut-ana/praesenz-9.xopp differ