From 6a7f82fac62ed2a26f1a5ccaf17786246eaee016 Mon Sep 17 00:00:00 2001 From: Chi-Kuang Yeh Date: Tue, 14 May 2024 23:45:30 -0600 Subject: [PATCH] Build vignette and inst/doc/ folder --- .Rbuildignore | 4 +- .gitignore | 2 + build/vignette.rds | Bin 0 -> 205 bytes inst/doc/evalRTPF-vignette.R | 135 +++ inst/doc/evalRTPF-vignette.Rmd | 162 +++ inst/doc/evalRTPF-vignette.html | 1776 +++++++++++++++++++++++++++++++ 6 files changed, 2078 insertions(+), 1 deletion(-) create mode 100644 build/vignette.rds create mode 100644 inst/doc/evalRTPF-vignette.R create mode 100644 inst/doc/evalRTPF-vignette.Rmd create mode 100644 inst/doc/evalRTPF-vignette.html diff --git a/.Rbuildignore b/.Rbuildignore index 21da4ac..2be8073 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,5 @@ ^evalRTPF\.Rproj$ ^\.Rproj\.user$ -^\.github$ \ No newline at end of file +^\.github$ +^doc$ +^Meta$ diff --git a/.gitignore b/.gitignore index cd67eac..9c2dc2c 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,3 @@ .Rproj.user +/doc/ +/Meta/ diff --git a/build/vignette.rds b/build/vignette.rds new file mode 100644 index 0000000000000000000000000000000000000000..0923051bc3718acde7e2ccf8dc540768d652b5e4 GIT binary patch literal 205 zcmV;;05bm{iwFP!0000018q^!3W6{cow_WAAdvct{0i}<7ZD$N9eFEZYUogU>&vsd zYLQn5_wH_-b9N3p`iwD~agN==(Fw4*SQ{*hapvK^g-*ycOX7W3Tq;ls!nDi@h(}P? zHzn?ZVYFHaZRwe zkYL`;3iUfUNfduaE2SPL`Xm2dQ}?0Cu-0Gjz&7BbK~GY&G^n2oCBk!qeC_)M;UO@Z H!~p;RJv3eQ literal 0 HcmV?d00001 diff --git a/inst/doc/evalRTPF-vignette.R b/inst/doc/evalRTPF-vignette.R new file mode 100644 index 0000000..78dd8de --- /dev/null +++ b/inst/doc/evalRTPF-vignette.R @@ -0,0 +1,135 @@ +## ----setup, include = FALSE--------------------------------------------------- +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +options(digits = 3) + +## ----load, message = F, include = FALSE--------------------------------------- +# required dependencies +require(dplyr) +require(tidyr) +# require(ggplot2) +require(gridExtra) +require(RSpectra) +require(rlist) + +## ----include = FALSE---------------------------------------------------------- +library(evalRTPF) +L <- function(x, y){ + return ( (x - y)^2 ) +} + +## ----------------------------------------------------------------------------- +library(ggplot2) +library(tibble) +library(MASS) +nsamp <- 100 # number of in-game events +ngame <- 100 # number of games + +#' Parameter for generating the eigenvalues, and p-values +D <- 10 # Number of eigenvalues to keep +N_MC <- 5000 # for simulating the p-value +L <- function(x, y) { + return((x - y) ^ 2) +} + +# Data generation ---------------------------------------------------------= +df_equ <- df_gen(N = nsamp, Ngame = ngame) %>% + group_by(grid) %>% + mutate( + p_bar_12 = mean(phat_A - phat_B), + diff_non_cent = phat_A - phat_B, + diff_cent = phat_A - phat_B - p_bar_12 + ) %>% ungroup() + +# Apply our test ---------------------------------------------------------- + +Z <- df_equ %>% group_by(grid) %>% + summarise(delta_n = mean(L(phat_A, Y) - L(phat_B, Y))) %>% + {sum((.)$delta_n ^ 2) / nsamp * ngame} + +temp <- df_equ %>% group_split(grid, .keep = FALSE) + +eigV_hat <- lapply(1:nsamp, function(i) { + sapply(1:nsamp, function(j) { + as.numeric(temp[[i]]$diff_non_cent %*% temp[[j]]$diff_non_cent / ngame) + }) +}) %>% list.rbind %>% { + eigs_sym( + A = (.), + k = D, + which = "LM", + opts = list(retvec = FALSE) + )$values +} %>% + { + (.) / nsamp + } + + + +eigV_til <- lapply(1:nsamp, function(i) { + sapply(1:nsamp, function(j) { + as.numeric(temp[[i]]$diff_cent %*% temp[[j]]$diff_cent / ngame) + }) +}) %>% list.rbind %>% { + eigs_sym( + A = (.), + k = D, + which = "LM", + opts = list(retvec = FALSE) + )$values +} %>% + { + (.) / nsamp + } + +MC_hat <- sapply(1:N_MC, function(x) { + crossprod(eigV_hat, rchisq(D, df = 1)) +}) + +q_90_hat <- quantile(MC_hat, 0.90) +q_95_hat <- quantile(MC_hat, 0.95) +q_99_hat <- quantile(MC_hat, 0.99) + +MC_til <- sapply(1:N_MC, function(x) { + crossprod(eigV_til, rchisq(D, df = 1)) +}) + +q_90_til <- quantile(MC_til, 0.90) +q_95_til <- quantile(MC_til, 0.95) +q_99_til <- quantile(MC_til, 0.99) + +p_hat <- 1 - ecdf(MC_hat)(Z) + +tibble( + type = c("non-center", "center"), + Z = rep(Z, 2), + "pval" = c(p_hat, p_hat), + "90%" = c(q_90_hat, q_90_til), + "95%" = c(q_95_hat, q_95_til), + "99%" = c(q_99_hat, q_99_til)) + +## ----function wrappers-------------------------------------------------------- +to_center <- FALSE + +ZZ <- calc_Z(df = df_equ, pA = "phat_A", pB = "phat_B", Y = "Y", nsamp = nsamp, ngame = ngame) +eigg <- calc_eig(df = df_equ, n_eig = D, ngame = ngame, + nsamp = nsamp, grid = "grid", cent = to_center) +oh <- calc_pval(ZZ, eig = eigg, quan = c(0.90, 0.95, 0.99), n_MC = N_MC) + + +temp <- calc_L_s2(df = df_equ, pA = "phat_A", pB = "phat_B") + +plot_pcb(df = temp) + +tibble( + type = ifelse(to_center, "center", "non-center"), + Z = ZZ, + pval = oh$p_val, + "90%" = oh$quantile[1], + "95%" = oh$quantile[2], + "99%" = oh$quantile[3] +) + diff --git a/inst/doc/evalRTPF-vignette.Rmd b/inst/doc/evalRTPF-vignette.Rmd new file mode 100644 index 0000000..d3db4e8 --- /dev/null +++ b/inst/doc/evalRTPF-vignette.Rmd @@ -0,0 +1,162 @@ +--- +title: "evalRTPF guide" +subtitle: "EVALuating Real-Time Probabilistic Forecast" +author: | + | Chi-Kuang Yeh, Gregory Rice, Joel A. Dubin + | University of Waterloo +date: "`r Sys.Date()`" +output: + rmarkdown::html_document: + toc: yes + toc_float: true + theme: readable + highlight: tango + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Demo} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +options(digits = 3) +``` + +```{r load, message = F, include = FALSE} +# required dependencies +require(dplyr) +require(tidyr) +# require(ggplot2) +require(gridExtra) +require(RSpectra) +require(rlist) +``` + +```{r, include = FALSE} +library(evalRTPF) +L <- function(x, y){ + return ( (x - y)^2 ) +} +``` + +```{r} +library(ggplot2) +library(tibble) +library(MASS) +nsamp <- 100 # number of in-game events +ngame <- 100 # number of games + +#' Parameter for generating the eigenvalues, and p-values +D <- 10 # Number of eigenvalues to keep +N_MC <- 5000 # for simulating the p-value +L <- function(x, y) { + return((x - y) ^ 2) +} + +# Data generation ---------------------------------------------------------= +df_equ <- df_gen(N = nsamp, Ngame = ngame) %>% + group_by(grid) %>% + mutate( + p_bar_12 = mean(phat_A - phat_B), + diff_non_cent = phat_A - phat_B, + diff_cent = phat_A - phat_B - p_bar_12 + ) %>% ungroup() + +# Apply our test ---------------------------------------------------------- + +Z <- df_equ %>% group_by(grid) %>% + summarise(delta_n = mean(L(phat_A, Y) - L(phat_B, Y))) %>% + {sum((.)$delta_n ^ 2) / nsamp * ngame} + +temp <- df_equ %>% group_split(grid, .keep = FALSE) + +eigV_hat <- lapply(1:nsamp, function(i) { + sapply(1:nsamp, function(j) { + as.numeric(temp[[i]]$diff_non_cent %*% temp[[j]]$diff_non_cent / ngame) + }) +}) %>% list.rbind %>% { + eigs_sym( + A = (.), + k = D, + which = "LM", + opts = list(retvec = FALSE) + )$values +} %>% + { + (.) / nsamp + } + + + +eigV_til <- lapply(1:nsamp, function(i) { + sapply(1:nsamp, function(j) { + as.numeric(temp[[i]]$diff_cent %*% temp[[j]]$diff_cent / ngame) + }) +}) %>% list.rbind %>% { + eigs_sym( + A = (.), + k = D, + which = "LM", + opts = list(retvec = FALSE) + )$values +} %>% + { + (.) / nsamp + } + +MC_hat <- sapply(1:N_MC, function(x) { + crossprod(eigV_hat, rchisq(D, df = 1)) +}) + +q_90_hat <- quantile(MC_hat, 0.90) +q_95_hat <- quantile(MC_hat, 0.95) +q_99_hat <- quantile(MC_hat, 0.99) + +MC_til <- sapply(1:N_MC, function(x) { + crossprod(eigV_til, rchisq(D, df = 1)) +}) + +q_90_til <- quantile(MC_til, 0.90) +q_95_til <- quantile(MC_til, 0.95) +q_99_til <- quantile(MC_til, 0.99) + +p_hat <- 1 - ecdf(MC_hat)(Z) + +tibble( + type = c("non-center", "center"), + Z = rep(Z, 2), + "pval" = c(p_hat, p_hat), + "90%" = c(q_90_hat, q_90_til), + "95%" = c(q_95_hat, q_95_til), + "99%" = c(q_99_hat, q_99_til)) +``` + + +```{r function wrappers} +to_center <- FALSE + +ZZ <- calc_Z(df = df_equ, pA = "phat_A", pB = "phat_B", Y = "Y", nsamp = nsamp, ngame = ngame) +eigg <- calc_eig(df = df_equ, n_eig = D, ngame = ngame, + nsamp = nsamp, grid = "grid", cent = to_center) +oh <- calc_pval(ZZ, eig = eigg, quan = c(0.90, 0.95, 0.99), n_MC = N_MC) + + +temp <- calc_L_s2(df = df_equ, pA = "phat_A", pB = "phat_B") + +plot_pcb(df = temp) + +tibble( + type = ifelse(to_center, "center", "non-center"), + Z = ZZ, + pval = oh$p_val, + "90%" = oh$quantile[1], + "95%" = oh$quantile[2], + "99%" = oh$quantile[3] +) +``` + diff --git a/inst/doc/evalRTPF-vignette.html b/inst/doc/evalRTPF-vignette.html new file mode 100644 index 0000000..a021a09 --- /dev/null +++ b/inst/doc/evalRTPF-vignette.html @@ -0,0 +1,1776 @@ + + + + + + + + + + + + + + +evalRTPF guide + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ + + +
+
+
+
+
+ +
+ + + + + + + +
library(ggplot2)
+library(tibble)
+library(MASS)
+#> 
+#> Attaching package: 'MASS'
+#> The following object is masked from 'package:dplyr':
+#> 
+#>     select
+nsamp <- 100 # number of in-game events
+ngame <- 100 # number of games
+
+#' Parameter for generating the eigenvalues, and p-values
+D <- 10 # Number of eigenvalues to keep
+N_MC <- 5000 # for simulating the p-value
+L <- function(x, y) {
+  return((x - y) ^ 2)
+}
+
+# Data generation ---------------------------------------------------------=
+df_equ <-  df_gen(N = nsamp, Ngame = ngame) %>%
+  group_by(grid) %>%
+  mutate(
+    p_bar_12 = mean(phat_A - phat_B),
+    diff_non_cent = phat_A - phat_B,
+    diff_cent = phat_A - phat_B - p_bar_12
+  ) %>% ungroup()
+
+# Apply our test ----------------------------------------------------------
+
+Z <- df_equ %>% group_by(grid) %>%
+  summarise(delta_n = mean(L(phat_A, Y) - L(phat_B, Y))) %>%
+  {sum((.)$delta_n ^ 2) / nsamp * ngame}
+
+temp <- df_equ %>% group_split(grid, .keep = FALSE)
+
+eigV_hat <- lapply(1:nsamp, function(i) {
+  sapply(1:nsamp, function(j) {
+    as.numeric(temp[[i]]$diff_non_cent %*% temp[[j]]$diff_non_cent / ngame)
+  })
+}) %>% list.rbind %>% {
+  eigs_sym(
+    A = (.),
+    k = D,
+    which = "LM",
+    opts = list(retvec = FALSE)
+  )$values
+} %>%
+  {
+    (.) / nsamp
+  }
+
+
+
+eigV_til <- lapply(1:nsamp, function(i) {
+  sapply(1:nsamp, function(j) {
+    as.numeric(temp[[i]]$diff_cent %*% temp[[j]]$diff_cent / ngame)
+  })
+}) %>% list.rbind %>% {
+  eigs_sym(
+    A = (.),
+    k = D,
+    which = "LM",
+    opts = list(retvec = FALSE)
+  )$values
+} %>%
+  {
+    (.) / nsamp
+  }
+
+MC_hat <- sapply(1:N_MC, function(x) {
+  crossprod(eigV_hat, rchisq(D, df = 1))
+})
+
+q_90_hat <- quantile(MC_hat, 0.90)
+q_95_hat <- quantile(MC_hat, 0.95)
+q_99_hat <- quantile(MC_hat, 0.99)
+
+MC_til <- sapply(1:N_MC, function(x) {
+  crossprod(eigV_til, rchisq(D, df = 1))
+})
+
+q_90_til <- quantile(MC_til, 0.90)
+q_95_til <- quantile(MC_til, 0.95)
+q_99_til <- quantile(MC_til, 0.99)
+
+p_hat <- 1 - ecdf(MC_hat)(Z)
+
+tibble(
+  type  = c("non-center", "center"),
+  Z = rep(Z, 2),
+  "pval" = c(p_hat, p_hat),
+  "90%" = c(q_90_hat, q_90_til),
+  "95%" = c(q_95_hat, q_95_til),
+  "99%" = c(q_99_hat, q_99_til))
+#> # A tibble: 2 × 6
+#>   type            Z  pval `90%` `95%` `99%`
+#>   <chr>       <dbl> <dbl> <dbl> <dbl> <dbl>
+#> 1 non-center 0.0262 0.869 0.388 0.540 0.877
+#> 2 center     0.0262 0.869 0.386 0.542 0.995
+
to_center <- FALSE
+
+ZZ <- calc_Z(df = df_equ, pA = "phat_A", pB = "phat_B", Y = "Y", nsamp = nsamp, ngame = ngame)
+eigg <- calc_eig(df = df_equ, n_eig = D, ngame = ngame, 
+                 nsamp = nsamp, grid = "grid", cent = to_center)
+oh <- calc_pval(ZZ, eig = eigg, quan = c(0.90, 0.95, 0.99), n_MC = N_MC)
+
+
+temp <- calc_L_s2(df = df_equ, pA = "phat_A", pB = "phat_B")
+
+plot_pcb(df = temp)
+

+

+tibble(
+  type = ifelse(to_center, "center", "non-center"),
+  Z = ZZ,
+  pval = oh$p_val,
+  "90%" = oh$quantile[1],
+  "95%" = oh$quantile[2],
+  "99%" = oh$quantile[3]
+)
+#> # A tibble: 1 × 6
+#>   type            Z  pval `90%` `95%` `99%`
+#>   <chr>       <dbl> <dbl> <dbl> <dbl> <dbl>
+#> 1 non-center 0.0262 0.882 0.411 0.557 0.913
+ + + +
+
+ +
+ + + + + + + + + + + + + + + +