A1 results now here

numbats · May 16, 2024 · e527ab2 · e527ab2
1 parent 0531892
commit e527ab2
Show file tree

Hide file tree

Showing 11 changed files with 263 additions and 6 deletions.
diff --git a/assignments/A1.R b/assignments/A1.R
@@ -0,0 +1,69 @@
+library(tidyverse)
+
+# Load some functions
+source(here::here("assignments/A1_functions.R"))
+
+# Read responses
+ass1 <- readRDS(here::here("assignments/A1_responses.rds"))
+
+# Actual values
+q1 <- q2 <- q3 <- q4 <- q5 <- NULL
+q1 <- 149.68 # https://finance.yahoo.com/quote/GOOG/history
+q2 <- 17.6 #http://www.bom.gov.au/climate/dwo/IDCJDW3049.latest.shtml
+q3 <- 0
+q4 <- 14.300000 #https://www.abs.gov.au/ausstats/[email protected]/mf/6202.0
+#q5 <- ???? # https://finance.yahoo.com/quote/GOOG/history
+
+# Create leaderboard
+leaders <- tibble(
+    Name = ass1[["Name"]],
+  ) |>
+  bind_cols(
+    score(1, q1, ass1[["Q1F"]], ass1[["Q1L"]], ass1[["Q1U"]]),
+    score(2, q2, ass1[["Q2F"]], ass1[["Q2L"]], ass1[["Q2U"]]),
+    score(3, q3, ass1[["Q3F"]], ass1[["Q3L"]], ass1[["Q3U"]]),
+    score(4, q4, ass1[["Q4F"]], ass1[["Q4L"]], ass1[["Q4U"]]),
+    score(5, q5, ass1[["Q5F"]], ass1[["Q5L"]], ass1[["Q5U"]])
+  ) |>
+  rowwise() |>
+  mutate(Score = sum(c_across(-Name))) |>
+  select(Name, Score, everything()) |>
+  arrange(Score, Name)
+
+# Save leaderboard
+saveRDS(leaders, here::here("assignments/A1_leaderboard.rds"))
+
+# Plotting
+ggplot2::theme_set(
+  theme_get() + theme(text = element_text(family = 'Fira Sans'))
+)
+
+# Plot responses
+savepng(here::here("assignments/Q1"), height = 80, width = 15)
+ass1 |> plotass1(F = Q1F, L = Q1L, U = Q1U, Actual = q1, xlab = "US dollars") +
+  ggtitle("Google stock price 20 March 2024")
+dev.off()
+
+savepng(here::here("assignments/Q2"), height = 80, width = 15)
+ass1 |> plotass1(F = Q2F, L = Q2L, U = Q2U, Actual = q2, xlab = "degrees C") +
+  ggtitle("Maximum temp at airport on 10 April 2024")
+dev.off()
+
+savepng(here::here("assignments/Q3"), height = 80, width = 15)
+ass1 |> plotass1(
+  F = Q3F, L = Q3L, U = Q3U, Actual = q3,
+  xlab = "Point difference (Collingwood - Essendon)"
+) +
+  ggtitle("Difference in points Anzac Day match")
+dev.off()
+
+savepng(here::here("assignments/Q4"), height = 80, width = 15)
+ass1 |> plotass1(F = Q4F, L = Q4L, U = Q4U, Actual = q4, xlab = "Millions") +
+  ggtitle("Seasonally adjusted total employment in April 2024") +
+  coord_cartesian(xlim=c(12, 15))
+dev.off()
+
+savepng(here::here("assignments/Q5"), height = 80, width = 15)
+ass1 |> plotass1(F = Q5F, L = Q5L, U = Q5U, Actual = q5, xlab = "US dollars") +
+  ggtitle("Google stock price 22 May 2024")
+dev.off()
diff --git a/assignments/A1.qmd b/assignments/A1.qmd
@@ -27,12 +27,15 @@ submit(schedule, "Assignment 1")
 
 ## Results
 
-* [Q1](https://robjhyndman.com/etc3550/Q1.png)
-* [Q2](https://robjhyndman.com/etc3550/Q2.png)
-* [Q3](https://robjhyndman.com/etc3550/Q3.png)
-* [Q4](https://robjhyndman.com/etc3550/Q4.png)
-* [Q5](https://robjhyndman.com/etc3550/Q5.png)
+* [Q1](Q1.png)
+* [Q2](Q2.png)
+* [Q3](Q3.png)
+* [Q4](Q4.png)
+* [Q5](Q5.png)
 
 ## Leaderboard
 
-<iframe src="https://docs.google.com/spreadsheets/d/e/2PACX-1vRiDdZRiT4hQK5b67XV3SZZSXm_hVHNwg1m4Jx3uUBxVREEsfhlcCgV-nNJRg-8l3IX8OuuQz5zQBnz/pubhtml?gid=185527398&amp;single=true&amp;widget=true&amp;headers=false" width = "100%" height = 500></iframe>
+```{r}
+readRDS(here::here("assignments/A1_leaderboard.rds")) |> 
+  DT::datatable()
+```
diff --git a/assignments/A1_functions.R b/assignments/A1_functions.R
@@ -0,0 +1,98 @@
+# Functions used for plotting and scoring Assignment 1 results
+
+plotass1 <- function(data, F, L, U, Actual = NULL, xlab = NULL) {
+  Fquo <- rlang::as_label(enquo(F))
+  p <- ass1 %>%
+    arrange({{ F }}) %>%
+    mutate(
+      Name = factor(Name, ordered = TRUE, levels = data$Name[order(data[[Fquo]])])
+    ) %>%
+    filter(!is.na({{ F }})) %>%
+    ggplot(aes(y = Name)) +
+    geom_linerange(aes(xmin = {{ L }}, xmax = {{ U }})) +
+    geom_point(aes(x = {{ F }}), col = "blue", size = .5) +
+    scale_x_continuous(sec.axis = dup_axis())
+  if (!is.null(Actual)) {
+    p <- p +
+      geom_vline(xintercept = Actual, col = "red")
+    xlab <- paste0(xlab, ". Actual = ", Actual)
+  }
+  if (!is.null(xlab)) {
+    p <- p + xlab(xlab)
+  }
+  xlim <- data %>%
+    summarise(
+      lower = quantile(c({{F}},{{L}}), 0.01, na.rm=TRUE),
+      upper = quantile(c({{F}},{{U}}), 0.99, na.rm=TRUE)
+    ) %>%
+    as.numeric()
+  p <- p + coord_cartesian(xlim=xlim)
+
+  return(p)
+}
+
+
+### Function to save eps or pdf figures
+
+savefig <- function(filename, height = 10, width = (1 + sqrt(5)) / 2 * height,
+                    type = c("pdf", "eps", "jpg", "png"), pointsize = 10, family = "Helvetica",
+                    sublines = 0, toplines = 0, leftlines = 0, res = 300, ...) {
+  type <- match.arg(type)
+  filename <- paste(filename, ".", type, sep = "")
+  if (type == "eps") {
+    postscript(
+      file = filename, horizontal = FALSE,
+      width = width / 2.54, height = height / 2.54, pointsize = pointsize,
+      family = family, onefile = TRUE, print.it = FALSE
+    )
+  }
+  else if (type == "pdf") {
+    pdf(
+      file = filename, width = width / 2.54, height = height / 2.54, pointsize = pointsize,
+      family = family, onefile = TRUE
+    )
+  }
+  else if (type == "jpg") {
+    ragg::agg_jpeg(filename = filename, width = width, height = height, res = res, quality = 100, units = "cm") # , pointsize=pointsize*50)
+  }
+  else if (type == "png") {
+    ragg::agg_png(filename = filename, width = width, height = height, res = res, units = "cm") # , pointsize=pointsize*50)
+  }
+  else {
+    stop("Unknown file type")
+  }
+  par(mgp = c(2.2, 0.45, 0), tcl = -0.4, mar = c(
+    3.2 + sublines + 0.25 * (sublines > 0),
+    3.5 + leftlines, 1 + toplines, 1
+  ) + 0.1)
+  par(pch = 1)
+  invisible()
+}
+
+savepng <- function(...) {
+  savefig(..., type = "png")
+}
+
+# Scoring function
+score <- function(question, actual, forecast, lower, upper) {
+  if(is.null(actual)) {
+    return(NULL)
+  } else {
+    # Correct reversal of upper and lower bounds
+    switch <- lower > upper
+    switch[is.na(switch)] <- FALSE
+    tmp <- upper
+    upper[switch] <- lower[switch]
+    lower[switch] <- tmp[switch]
+    # Point forecast score
+    rank1 <- rank(abs(actual - forecast))
+    # Interval forecast score
+    interval_score <- (upper - lower) +
+      10 * pmax(0, lower - actual) + 10 * pmax(0, actual - upper)
+    rank2 <- rank(interval_score)
+    # Return results
+    out <- as_tibble(cbind(point = rank1, interval = rank2))
+    colnames(out) <- paste0("Q", question, "_", colnames(out))
+    return(out)
+  }
+}
diff --git a/assignments/A1_leaderboard.rds b/assignments/A1_leaderboard.rds
diff --git a/assignments/A1_responses.rds b/assignments/A1_responses.rds
diff --git a/assignments/Q1.png b/assignments/Q1.png
diff --git a/assignments/Q2.png b/assignments/Q2.png
diff --git a/assignments/Q3.png b/assignments/Q3.png
diff --git a/assignments/Q4.png b/assignments/Q4.png
diff --git a/assignments/Q5.png b/assignments/Q5.png
diff --git a/renv.lock b/renv.lock
@@ -27,6 +27,23 @@
       ],
       "Hash": "164809cd72e1d5160b4cb3aa57f510fe"
     },
+    "DT": {
+      "Package": "DT",
+      "Version": "0.33",
+      "Source": "Repository",
+      "Repository": "CRAN",
+      "Requirements": [
+        "crosstalk",
+        "htmltools",
+        "htmlwidgets",
+        "httpuv",
+        "jquerylib",
+        "jsonlite",
+        "magrittr",
+        "promises"
+      ],
+      "Hash": "64ff3427f559ce3f2597a4fe13255cb6"
+    },
     "GGally": {
       "Package": "GGally",
       "Version": "2.2.1",
@@ -554,6 +571,19 @@
       ],
       "Hash": "e8a1e41acf02548751f45c718d55aa6a"
     },
+    "crosstalk": {
+      "Package": "crosstalk",
+      "Version": "1.2.1",
+      "Source": "Repository",
+      "Repository": "CRAN",
+      "Requirements": [
+        "R6",
+        "htmltools",
+        "jsonlite",
+        "lazyeval"
+      ],
+      "Hash": "ab12c7b080a57475248a30f4db6298c0"
+    },
     "curl": {
       "Package": "curl",
       "Version": "5.2.1",
@@ -1270,6 +1300,36 @@
       ],
       "Hash": "81d371a9cc60640e74e4ab6ac46dcedc"
     },
+    "htmlwidgets": {
+      "Package": "htmlwidgets",
+      "Version": "1.6.4",
+      "Source": "Repository",
+      "Repository": "CRAN",
+      "Requirements": [
+        "grDevices",
+        "htmltools",
+        "jsonlite",
+        "knitr",
+        "rmarkdown",
+        "yaml"
+      ],
+      "Hash": "04291cc45198225444a397606810ac37"
+    },
+    "httpuv": {
+      "Package": "httpuv",
+      "Version": "1.6.15",
+      "Source": "Repository",
+      "Repository": "CRAN",
+      "Requirements": [
+        "R",
+        "R6",
+        "Rcpp",
+        "later",
+        "promises",
+        "utils"
+      ],
+      "Hash": "d55aa087c47a63ead0f6fc10f8fa1ee0"
+    },
     "httr": {
       "Package": "httr",
       "Version": "1.4.7",
@@ -1421,6 +1481,17 @@
       ],
       "Hash": "f8901f44aedb6d7e7d03b5533986bd97"
     },
+    "later": {
+      "Package": "later",
+      "Version": "1.3.2",
+      "Source": "Repository",
+      "Repository": "CRAN",
+      "Requirements": [
+        "Rcpp",
+        "rlang"
+      ],
+      "Hash": "a3e051d405326b8b0012377434c62b37"
+    },
     "latex2exp": {
       "Package": "latex2exp",
       "Version": "0.9.6",
@@ -1843,6 +1914,22 @@
       ],
       "Hash": "ac50c4ffa8f6a46580dd4d7813add3c4"
     },
+    "promises": {
+      "Package": "promises",
+      "Version": "1.3.0",
+      "Source": "Repository",
+      "Repository": "CRAN",
+      "Requirements": [
+        "R6",
+        "Rcpp",
+        "fastmap",
+        "later",
+        "magrittr",
+        "rlang",
+        "stats"
+      ],
+      "Hash": "434cd5388a3979e74be5c219bcd6e77d"
+    },
     "proxy": {
       "Package": "proxy",
       "Version": "0.4-27",