add this week

sose2021/r/w08/P08-1.R

@@ -0,0 +1,5 @@
+# Josua Kugler, Christian Merten
+
+library(rlang)
+
+`%->%` <- function(value, x) eval.parent(substitute(x <- value))

sose2021/r/w08/P08-2.R

@@ -0,0 +1,50 @@
+# Josua Kugler, Christian Merten
+
+library(tidyverse)
+library(rlang)
+
+variables <- LETTERS[1:7]
+names(variables) <- variables
+prop_ops <- exprs(`(`,`!`,`&`,`|`,`<=`,`>=`,`==`)
+prop_ops_str <- sapply(prop_ops, expr_text)
+ops_expr_str <- c("==", "<=", ">=", "&", "|", "!")
+ops_print_str <- c("\u2194","\u2190","\u2192","\u2227","\u2228","\u00AC")
+names(ops_print_str) <- ops_expr_str
+
+flip <- function(f) function(x,y) f(y,x)
+implies <- function(A, B) (!A) | B
+
+validate_Prop <- function(e) {
+    stopifnot("class must be Prop" = "Prop" %in% class(e))
+    stopifnot("only numbers 0 and 1 allowed" = !str_detect(expr_text(e), "[2-9]"))
+    stopifnot("invalid operator or variable" = all(all.names(e) %in% c(variables, ops_expr_str, "(", ")")))
+    e
+}
+
+Prop <- function(x) {
+    e <- enexpr(x)
+    if (typeof(e) == "symbol") e <- expr(( (!!e) ))
+    validate_Prop(structure(e, class="Prop"))
+}
+
+tochar <- function(p) str_replace_all(expr_text(p), fixed(ops_print_str))
+
+print.Prop <- function(p) {
+    cat(tochar(p), "\n")
+    invisible(p)
+}
+
+interprete <- function(prop, vars, append=FALSE) {
+    res <- as.logical(eval_tidy(prop, c(as.list(vars),
+                                        `>=` = implies,
+                                        `<=` = flip(implies))))
+    var <- tochar(prop)
+    if(append) add_column(vars, (!!sym(var)) := res)
+    else res
+}
+
+combinations <- do.call(expand.grid, lapply(variables, function(v) c(0,1)))
+
+is_tautology <- function(prop) {
+    all(interprete(prop, combinations))
+}

sose2021/r/w08/P08-3.R

@@ -0,0 +1,32 @@
+# Josua Kugler, Christian Merten
+
+library(tidyverse)
+
+# a)
+rate <- function(df, expr, name) {
+    t <- summarize(df, total := sum({{expr}}))
+    mutate(df, {{name}} := {{expr}} / t$total)
+}
+
+#b)
+show_na <- function(df, expr) df %>% filter(is.na({{expr}}))
+
+#c)
+ggplot_line <- function(df, expr_x, expr_y)
+    df %>% ggplot(aes(x = {{expr_x}}, y = {{expr_y}})) + geom_line()
+
+#d)
+athletes <- read_csv("athletes.csv")
+medal_color <- c(Bronze = "#6A3805", Silver = "#B4B4B4", Gold = "#AF9500")
+
+plot_olympia <- function(event, sex, metric) {
+    athletes %>% filter(Event == event , Sex == sex) %>%
+        mutate (Year = as.factor(Year)) ->
+        d
+
+    ggplot(d, aes(x = Year, y = {{metric}})) +
+        geom_boxplot (na.rm = TRUE) +
+        geom_point (data = drop_na (d), aes(color = Medal)) +
+        scale_color_manual (values = medal_color) +
+        ggtitle(str_c(event, sex, sep = ", "))
+}