├── _config.yml ├── .gitattributes ├── screenshots.gif ├── kmeans ├── screenshot.png ├── kmeans.Rproj ├── readme.md └── app.R ├── arma-process ├── Rplots.pdf ├── screenshot.png ├── readme.md ├── arma-process.Rproj └── app.R ├── bias-variance ├── screenshot.png ├── bias-variance.Rproj ├── readme.md └── app.R ├── decision-tree ├── screenshot.png ├── decision-tree.Rproj ├── readme.md └── app.R ├── kmeans-images ├── screenshot.png ├── www │ └── imgs │ │ ├── chess.jpg │ │ ├── parrot.jpg │ │ ├── minions.jpg │ │ ├── big hero 6.jpg │ │ ├── tulip farm.jpg │ │ ├── moon & earth.jpg │ │ ├── yoda green is.jpg │ │ └── circular gradient.jpg ├── kmeans-images.Rproj ├── readme.md └── app.R ├── lorenz-attractor ├── screenshot.png ├── readme.md └── app.R ├── matrix-decompositions ├── www │ ├── wp.png │ ├── matrix.jpg │ ├── matrix.ttf │ ├── matrix.regular.ttf │ ├── custom.css │ └── readme.txt ├── screenshot.png ├── helpers.R ├── matrix-decompositions.Rproj ├── global.R ├── readme.md ├── ui.R ├── rmd │ ├── lu.Rmd │ ├── qr.Rmd │ ├── eigen.Rmd │ ├── cholesky.Rmd │ ├── svd.Rmd │ └── temp.html └── server.R ├── logistic-regression ├── screenshot.png ├── readme.md ├── logistic-regression.Rproj └── app.R ├── .gitignore ├── shiny-apps-edu.Rproj ├── binary-predictions-metrics ├── binary-predictions-metrics.Rproj ├── readme.md └── app.R ├── run_app.R ├── deploy_apps.R ├── README.md └── readme.Rmd /_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-minimal -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.js linguist-vendored 2 | *.css linguist-vendored -------------------------------------------------------------------------------- /screenshots.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/screenshots.gif -------------------------------------------------------------------------------- /kmeans/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/kmeans/screenshot.png -------------------------------------------------------------------------------- /arma-process/Rplots.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/arma-process/Rplots.pdf -------------------------------------------------------------------------------- /arma-process/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/arma-process/screenshot.png -------------------------------------------------------------------------------- /bias-variance/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/bias-variance/screenshot.png -------------------------------------------------------------------------------- /decision-tree/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/decision-tree/screenshot.png -------------------------------------------------------------------------------- /kmeans-images/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/kmeans-images/screenshot.png -------------------------------------------------------------------------------- /lorenz-attractor/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/lorenz-attractor/screenshot.png -------------------------------------------------------------------------------- /kmeans-images/www/imgs/chess.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/kmeans-images/www/imgs/chess.jpg -------------------------------------------------------------------------------- /kmeans-images/www/imgs/parrot.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/kmeans-images/www/imgs/parrot.jpg -------------------------------------------------------------------------------- /matrix-decompositions/www/wp.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/matrix-decompositions/www/wp.png -------------------------------------------------------------------------------- /kmeans-images/www/imgs/minions.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/kmeans-images/www/imgs/minions.jpg -------------------------------------------------------------------------------- /logistic-regression/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/logistic-regression/screenshot.png -------------------------------------------------------------------------------- /matrix-decompositions/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/matrix-decompositions/screenshot.png -------------------------------------------------------------------------------- /matrix-decompositions/www/matrix.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/matrix-decompositions/www/matrix.jpg -------------------------------------------------------------------------------- /matrix-decompositions/www/matrix.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/matrix-decompositions/www/matrix.ttf -------------------------------------------------------------------------------- /kmeans-images/www/imgs/big hero 6.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/kmeans-images/www/imgs/big hero 6.jpg -------------------------------------------------------------------------------- /kmeans-images/www/imgs/tulip farm.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/kmeans-images/www/imgs/tulip farm.jpg -------------------------------------------------------------------------------- /kmeans-images/www/imgs/moon & earth.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/kmeans-images/www/imgs/moon & earth.jpg -------------------------------------------------------------------------------- /kmeans-images/www/imgs/yoda green is.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/kmeans-images/www/imgs/yoda green is.jpg -------------------------------------------------------------------------------- /kmeans-images/www/imgs/circular gradient.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/kmeans-images/www/imgs/circular gradient.jpg -------------------------------------------------------------------------------- /matrix-decompositions/www/matrix.regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jbkunst/shiny-apps-educational/HEAD/matrix-decompositions/www/matrix.regular.ttf -------------------------------------------------------------------------------- /arma-process/readme.md: -------------------------------------------------------------------------------- 1 | App made by [@jbkunst](https://twitter.com/jbkunst) with ❤️ and for fun with #rstats. Code 2 | [here](https://github.com/jbkunst/shiny-apps-educational). -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *\.Rproj.user 2 | *\.Rhistory 3 | *\.httr-oauth 4 | *\.dcf 5 | .httr-oauth 6 | 7 | rchessbase/data/* 8 | 9 | *\shinyapps\* 10 | .Rproj.user 11 | 12 | .DS_Store -------------------------------------------------------------------------------- /matrix-decompositions/www/custom.css: -------------------------------------------------------------------------------- 1 | @font-face { 2 | font-family: "matrix"; 3 | src: url("matrix.ttf") format("truetype"); 4 | } 5 | 6 | .title { 7 | font-family: "matrix"; 8 | text-transform:uppercase; 9 | } 10 | -------------------------------------------------------------------------------- /logistic-regression/readme.md: -------------------------------------------------------------------------------- 1 | Inspiration from: 2 | - https://lisyarus.github.io/webgl/classification.html 3 | 4 | App made by [@jbkunst](https://twitter.com/jbkunst) with ❤️ and for fun with #rstats. Code 5 | [here](https://github.com/jbkunst/shiny-apps-educational). -------------------------------------------------------------------------------- /kmeans/kmeans.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /arma-process/arma-process.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /bias-variance/bias-variance.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /decision-tree/decision-tree.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /kmeans-images/kmeans-images.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /logistic-regression/logistic-regression.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /matrix-decompositions/helpers.R: -------------------------------------------------------------------------------- 1 | matrix2latex <- function(matr) { 2 | 3 | out <- apply(matr, 1, function(r) str_c(r, collapse = " & ")) |> 4 | str_c(collapse = "\\\\") 5 | 6 | out <- str_c( 7 | "\\begin{pmatrix}", 8 | out, 9 | "\\end{pmatrix}" 10 | ) 11 | 12 | out 13 | 14 | } -------------------------------------------------------------------------------- /decision-tree/readme.md: -------------------------------------------------------------------------------- 1 | Inspiration y resources: 2 | - http://www.r2d3.us/visual-intro-to-machine-learning-part-1/ 3 | - https://mlu-explain.github.io/decision-tree/ 4 | 5 | App made by [@jbkunst](https://twitter.com/jbkunst) with ❤️ and for fun with #rstats. Code 6 | [here](https://github.com/jbkunst/shiny-apps-educational). -------------------------------------------------------------------------------- /shiny-apps-edu.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | ProjectId: b8640c1b-a6f1-4987-9b6e-79a0dd985824 3 | 4 | RestoreWorkspace: Default 5 | SaveWorkspace: Default 6 | AlwaysSaveHistory: Default 7 | 8 | EnableCodeIndexing: Yes 9 | UseSpacesForTab: Yes 10 | NumSpacesForTab: 2 11 | Encoding: UTF-8 12 | 13 | RnwWeave: Sweave 14 | LaTeX: pdfLaTeX 15 | -------------------------------------------------------------------------------- /matrix-decompositions/matrix-decompositions.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | -------------------------------------------------------------------------------- /binary-predictions-metrics/binary-predictions-metrics.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | ProjectId: 38aac83a-493f-4201-beb1-3892fd475ae2 3 | 4 | RestoreWorkspace: Default 5 | SaveWorkspace: Default 6 | AlwaysSaveHistory: Default 7 | 8 | EnableCodeIndexing: Yes 9 | UseSpacesForTab: Yes 10 | NumSpacesForTab: 2 11 | Encoding: UTF-8 12 | 13 | RnwWeave: Sweave 14 | LaTeX: pdfLaTeX 15 | -------------------------------------------------------------------------------- /matrix-decompositions/global.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(knitr) 3 | library(bslib) 4 | library(stringr) 5 | library(htmltools) 6 | library(here) 7 | library(markdown) 8 | 9 | # matrix2latex funcion is needed in .Rmds 10 | source("helpers.R") 11 | 12 | theme_matrix <- bs_theme( 13 | bg = "#020204", 14 | fg = "#92E5A1", 15 | primary = "#22B455", 16 | base_font = font_google("IBM Plex Sans") 17 | ) -------------------------------------------------------------------------------- /matrix-decompositions/readme.md: -------------------------------------------------------------------------------- 1 | Some decompositions do not require a square matrix, in this app we will use square real value matrix for simplicity. 2 | 3 | This idea came from the @kareem_carr [tweet](https://twitter.com/kareem_carr/status/1475255675718709250) 😅 4 | 5 | App made by [@jbkunst](https://twitter.com/jbkunst) with ❤️ and for fun with #rstats. Code 6 | [here](https://github.com/jbkunst/shiny-apps-educational). 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /kmeans/readme.md: -------------------------------------------------------------------------------- 1 | Resources and inspiration: 2 | 3 | 4 | - [K-means Cluster Analysis](https://uc-r.github.io/kmeans_clustering) by UC Business Analytics R Programming Guide. 5 | - [K-means shiny example](https://shiny.rstudio.com/gallery/kmeans-example.html). 6 | - [Clustering algorithms](https://nms.kcl.ac.uk/colin.cooper/teachingmaterial/CSMWAL/CSMWAL/Lectures/ClusterSlides.pdf). 7 | 8 | App made by [@jbkunst](https://twitter.com/jbkunst) with ❤️ and for fun with #rstats. Code 9 | [here](https://github.com/jbkunst/shiny-apps-educational). -------------------------------------------------------------------------------- /binary-predictions-metrics/readme.md: -------------------------------------------------------------------------------- 1 | Resources and inspiration: 2 | 3 | 4 | - [K-means Cluster Analysis](https://uc-r.github.io/kmeans_clustering) by UC Business Analytics R Programming Guide. 5 | - [K-means shiny example](https://shiny.rstudio.com/gallery/kmeans-example.html). 6 | - [Clustering algorithms](https://nms.kcl.ac.uk/colin.cooper/teachingmaterial/CSMWAL/CSMWAL/Lectures/ClusterSlides.pdf). 7 | 8 | App made by [@jbkunst](https://twitter.com/jbkunst) with ❤️ and for fun with #rstats. Code 9 | [here](https://github.com/jbkunst/shiny-apps-educational). -------------------------------------------------------------------------------- /kmeans-images/readme.md: -------------------------------------------------------------------------------- 1 | In evey image each pixel have a color and every color have an rgb representation 2 | (a 3-coordinates point), so we can group the colors into clusters and see what happens. 3 | The pixel have a position too so a pixel can be represented as a 5 tuple of values. 4 | The idea behind this app is taken from [dsparks' kmeans palette](https://gist.github.com/dsparks/3980277). I just add some features like 3d scatterplot and migrate the code to a shiny app. 5 | 6 | App made by [@jbkunst](https://twitter.com/jbkunst) with ❤️ and for fun with #rstats. Code 7 | [here](https://github.com/jbkunst/shiny-apps-educational). -------------------------------------------------------------------------------- /run_app.R: -------------------------------------------------------------------------------- 1 | run_app <- function(app = "kmeans"){ 2 | 3 | url <- "https://github.com/jbkunst/shiny-apps-educational/archive/refs/heads/master.zip" 4 | 5 | filePath <- tempfile("shinyapp", fileext = ".zip") 6 | fileDir <- tempfile("shinyapp") 7 | 8 | cli::cli_inform("Downloading {url}") 9 | 10 | download.file(url, filePath) 11 | 12 | try(utils::unzip(filePath, exdir = fileDir)) 13 | 14 | fp <- file.path(fileDir, "shiny-apps-educational-master", app) 15 | 16 | shiny::runApp(fp) 17 | 18 | # app_rmd <- stringr::str_subset(dir(fp, full.names = TRUE), "app.Rmd") 19 | # rmarkdown::run(app_rmd) 20 | 21 | } 22 | 23 | # run_app("kmeans") -------------------------------------------------------------------------------- /bias-variance/readme.md: -------------------------------------------------------------------------------- 1 | Inspiration y resources: 2 | 3 | - MLU [Bias Variance tradeoff](https://mlu-explain.github.io/bias-variance/) by Jared Wilber & Brent Werness. 4 | - [Understanding the Bias-Variance Tradeoff](https://scott.fortmann-roe.com/docs/BiasVariance.html). 5 | - [Nadaraya–Watson kernel regression](https://en.wikipedia.org/wiki/Kernel_regression#Nadaraya%E2%80%93Watson_kernel_regression). 6 | - [Kernel smoothing](https://bl.ocks.org/rpgove/073d6cb996d7de1d52935790139c4240) D3 Block by Robert Gove. 7 | 8 | 9 | App made by [@jbkunst](https://twitter.com/jbkunst) with ❤️ and for fun with #rstats. Code 10 | [here](https://github.com/jbkunst/shiny-apps-educational). 11 | -------------------------------------------------------------------------------- /matrix-decompositions/www/readme.txt: -------------------------------------------------------------------------------- 1 | Siesta Fonts -- http://rubberducky.nu/siesta 2 | 3 | All my fonts are unrestricted freeware for personal use. They are not allowed to be used in any sort of commercial package - if anyone's going to make money out of my creations it'll be me, thank you very much. 4 | 5 | If you do use any of my fonts, it would be great if you could let me know - just out of courtesy - I like to know my fonts are being used. The fonts may be distributed freely as freeware, as long as they retain their readme text files. If you wish to include one or more fonts in an online archive, again let me know - and if possible a link would be great. 6 | 7 | You may not rename or rework/edit any of my fonts without my permission, or distribute them without the relevant readme file. 8 | 9 | -Charlotte 10 | siesta@rubberducky.nu -------------------------------------------------------------------------------- /deploy_apps.R: -------------------------------------------------------------------------------- 1 | library(tidyverse) 2 | 3 | apps <- dir(recursive = TRUE) |> 4 | str_subset("app.R|app.Rmd") |> 5 | dirname() |> 6 | str_subset("older", negate = TRUE) |> 7 | str_subset("\\.", negate = TRUE) 8 | 9 | apps_valid <- map(apps, dir) |> 10 | map(str_detect, "ui.R|server.R|app.Rmd|app.R") |> 11 | map_lgl(any) 12 | 13 | apps <- apps[apps_valid] 14 | 15 | apps <- setdiff(apps, c("binary-predictions-metrics")) 16 | 17 | if(FALSE){ 18 | # delete all rsconnect folders 19 | fs::dir_ls(recurse = TRUE) |> 20 | stringr::str_subset("rsconnect$") |> 21 | fs::dir_delete() 22 | } 23 | 24 | walk(apps, function(app = "arma-process"){ 25 | 26 | cli::cli_h1(basename(app)) 27 | cli::cli_inform(app) 28 | 29 | if(fs::dir_exists(fs::path(app, "rsconnect"))) return(TRUE) 30 | 31 | rsconnect::deployApp(appDir = app, logLevel = "normal", forceUpdate = TRUE) 32 | 33 | }) 34 | -------------------------------------------------------------------------------- /lorenz-attractor/readme.md: -------------------------------------------------------------------------------- 1 | The **Lorenz Attractor** is a set of chaotic solutions to a system of differential equations originally derived by Edward Lorenz in 1963 to model atmospheric convection. It serves as a classic example of deterministic chaos, where small differences in initial conditions can lead to vastly different outcomes. 2 | 3 | The Equations of the system is defined by three differential equations: 4 | 5 | $$\frac{{dx}}{{dt}} = \sigma (y - x),$$ 6 | $$\frac{{dy}}{{dt}} = x (\rho - z) - y,$$ 7 | $$\frac{{dz}}{{dt}} = x y - \beta z.$$ 8 | 9 | Key Features are: 10 | - **Chaotic behavior:** Sensitive dependence on initial conditions. 11 | - **Fractal structure:** Exhibits a non-integer dimension. 12 | - **Aesthetic patterns:** Produces a "butterfly-shaped" trajectory. 13 | 14 | Some Applications: 15 | - Meteorology and climate modeling. 16 | - Chaos theory and nonlinear dynamics. 17 | - Visualization of complex systems. 18 | 19 | App made by [@jbkunst](https://twitter.com/jbkunst) with ❤️ and for fun with #rstat and shiny assistant. Code 20 | [here](https://github.com/jbkunst/shiny-apps-educational). -------------------------------------------------------------------------------- /matrix-decompositions/ui.R: -------------------------------------------------------------------------------- 1 | page_sidebar( 2 | title = tags$h4("MATRIX DECOMPOSITIONS", class = "title"), 3 | theme = theme_matrix, 4 | fluid = TRUE, 5 | sidebar = sidebar( 6 | width = 350, 7 | withMathJax(), 8 | tags$head( 9 | tags$link(rel = "stylesheet", type = "text/css", href = "custom.css") 10 | ), 11 | radioButtons( 12 | "decomposition", 13 | tags$strong("Decomposition"), 14 | choices = list( 15 | "SVD" = "svd", 16 | "Eigen" = "eigen", 17 | "\\(QR\\)" = "qr", 18 | "\\(LU\\)" = "lu", 19 | "Cholesky" = "cholesky" 20 | ) 21 | ), 22 | textAreaInput( 23 | "matrix", 24 | label = tags$strong("Matrix values"), 25 | rows = 4, 26 | # value = "1, 2,3,\n2, 4.5, 6,\n3, 3, 3" 27 | value = "4, 12, -16, 12, 37, -43, -16, -43, 98" 28 | # value = "1, 2\n2, 1" 29 | ), 30 | sliderInput( 31 | "nrows", 32 | label = tags$strong("Number of rows and cols"), 33 | min = 2, 34 | max = 5, 35 | value = 3 36 | ), 37 | htmlOutput("matrix_render"), 38 | tags$small( 39 | "Some decompositions do not require a square matrix, 40 | in this app we will use square real value matrix for simplicity" 41 | ), 42 | includeMarkdown("readme.md") 43 | ), 44 | htmlOutput("decomposition_output") 45 | ) -------------------------------------------------------------------------------- /matrix-decompositions/rmd/lu.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "lu" 3 | output: html_document 4 | params: 5 | mat: !r matrix(c(1, 2, 3, 4), ncol = 2) 6 | editor_options: 7 | chunk_output_type: console 8 | --- 9 | 10 | ```{r, include=FALSE} 11 | # params <- list(mat = matrix(c(1, 2, 3, 4), ncol = 2)) 12 | library(stringr) 13 | knitr::opts_chunk$set(echo = FALSE) 14 | source(here::here("helpers.R")) 15 | ``` 16 | 17 |

Lower–Upper (LU) decomposition

18 | 19 | In numerical analysis and linear algebra, lower-upper (LU) decomposition or factorization factors a matrix as the product of a lower triangular matrix and an upper triangular matrix. The product sometimes includes a permutation matrix as well. LU decomposition can be viewed as the matrix form of Gaussian elimination. Computers usually solve square systems of linear equations using LU decomposition, and it is also a key step when inverting a matrix or computing the determinant of a matrix. The LU decomposition was introduced by the Polish mathematician Tadeusz Banachiewicz in 1938. 20 | 21 | ```{r, results='asis'} 22 | library(matrixcalc) 23 | lu.mat <- lu.decomposition(params$mat) 24 | 25 | L <- lu.mat$L 26 | U <- lu.mat$U 27 | 28 | # params$mat - (L %*% U) 29 | 30 | Lf <- round(L, 5) 31 | Uf <- round(U, 5) 32 | 33 | cat( 34 | str_c( 35 | "$$ A = ", 36 | matrix2latex(Lf), 37 | " \\times ", 38 | matrix2latex(Uf), 39 | "$$" 40 | ) 41 | ) 42 | ``` 43 | 44 | Source https://en.wikipedia.org/wiki/LU_decomposition 45 | 46 | 47 | -------------------------------------------------------------------------------- /matrix-decompositions/rmd/qr.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "qr" 3 | output: html_document 4 | params: 5 | mat: !r matrix(c(1, 2, 3, 4), ncol = 2) 6 | editor_options: 7 | chunk_output_type: console 8 | --- 9 | 10 | ```{r, include=FALSE} 11 | # params <- list(mat = matrix(c(1, 2, 3, 4), ncol = 2)) 12 | library(stringr) 13 | knitr::opts_chunk$set(echo = FALSE) 14 | source(here::here("helpers.R")) 15 | ``` 16 | 17 |

QR decomposition

18 | 19 | In linear algebra, a QR decomposition, also known as a QR factorization or QU factorization, is a decomposition of a matrix $A$ into a product $A = QR$ of an orthogonal matrix $Q$ and an upper triangular matrix $R$. QR decomposition is often used to solve the linear least squares problem and is the basis for a particular eigenvalue algorithm, the QR algorithm. 20 | 21 | 22 | ```{r, results='asis'} 23 | qr.mat <- qr(params$mat) 24 | 25 | Q <- qr.Q(qr.mat) 26 | 27 | R <- qr.R(qr.mat) 28 | 29 | Qf <- round(Q, 5) 30 | Rf <- round(R, 5) 31 | 32 | cat( 33 | str_c( 34 | "$$ A = ", 35 | matrix2latex(Qf), 36 | " \\times ", 37 | matrix2latex(Rf), 38 | "$$" 39 | ) 40 | ) 41 | ``` 42 | 43 | And $Q$ is an orthogonal because $Q^{\mathrm {T} }Q=QQ^{\mathrm {T} }=I$. 44 | 45 | ```{r, results='asis'} 46 | QtQ <- t(Qf) %*% Qf 47 | QtQf <- round(QtQ, 5) 48 | 49 | Qtf <- round(t(Q), 5) 50 | 51 | cat( 52 | str_c( 53 | "$$ Q^{\\mathrm {T} }Q = ", 54 | matrix2latex(t(Qf)), 55 | " \\times ", 56 | matrix2latex(Qf), 57 | " = ", 58 | matrix2latex(QtQf), 59 | "$$" 60 | ) 61 | ) 62 | ``` 63 | 64 | 65 | Source https://en.wikipedia.org/wiki/QR_decomposition 66 | -------------------------------------------------------------------------------- /matrix-decompositions/rmd/eigen.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "eigen" 3 | output: html_document 4 | params: 5 | mat: !r matrix(c(1, 2, 3, 4), ncol = 2) 6 | editor_options: 7 | chunk_output_type: console 8 | --- 9 | 10 | ```{r, include=FALSE} 11 | # params <- list(mat = matrix(c(1, 2, 3, 4), ncol = 2)) 12 | library(stringr) 13 | knitr::opts_chunk$set(echo = FALSE) 14 | source(here::here("helpers.R")) 15 | ``` 16 | 17 |

Eigen decomposition of a matrix

18 | 19 | In linear algebra, eigendecomposition is the factorization of a matrix into a canonical form, whereby the matrix is represented in terms of its eigenvalues and eigenvectors. Only diagonalizable matrices can be factorized in this way. When the matrix being factorized is a normal or real symmetric matrix, the decomposition is called "spectral decomposition", derived from the spectral theorem. 20 | 21 | Decomposition have the form ${\displaystyle A=VDV^{-1}}$, where $D$ is a diagonal matrix formed from the eigenvalues of $A$, and the columns of $V$ are the corresponding eigenvectors of $A$. 22 | 23 | 24 | ```{r, results='asis'} 25 | # params$mat <- params$mat + t(params$mat) 26 | eigen.mat <- eigen(params$mat) 27 | 28 | D <- diag(eigen.mat$values) 29 | V <- eigen.mat$vectors 30 | 31 | Df <- round(D, 5) 32 | Vf <- round(V, 5) 33 | Vm1f <- round(solve(V), 5) 34 | 35 | # V %*% D %*% solve(V) 36 | 37 | cat( 38 | str_c( 39 | "$$ A = ", 40 | matrix2latex(Vf), 41 | " \\times ", 42 | matrix2latex(Df), 43 | " \\times ", 44 | matrix2latex(Vm1f), 45 | "$$" 46 | ) 47 | ) 48 | ``` 49 | 50 | 51 | 52 | Sources: 53 | 54 | - https://en.wikipedia.org/wiki/Eigendecomposition_of_a_matrix 55 | - https://r-snippets.readthedocs.io/en/latest/la/svd.html 56 | 57 | 58 | -------------------------------------------------------------------------------- /matrix-decompositions/rmd/cholesky.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "cholesky" 3 | output: html_document 4 | params: 5 | mat: !r matrix(c(4, 12, -16, 12, 37, -43, -16, -43, 98), nrow = 3) 6 | editor_options: 7 | chunk_output_type: console 8 | --- 9 | 10 | ```{r, include=FALSE} 11 | # params <- list(mat = matrix(c(4, 12, -16, 12, 37, -43, -16, -43, 98), nrow = 3)) 12 | library(stringr) 13 | knitr::opts_chunk$set(echo = FALSE) 14 | source(here::here("helpers.R")) 15 | ``` 16 | 17 |

Cholesky decomposition

18 | 19 | In linear algebra, the Cholesky decomposition or Cholesky factorization is a decomposition of a Hermitian, positive-definite matrix into the product of a lower triangular matrix and its conjugate transpose, which is useful for efficient numerical solutions, e.g., Monte Carlo simulations. It was discovered by André-Louis Cholesky for real matrices, and posthumously published in 1924. When it is applicable, the Cholesky decomposition is roughly twice as efficient as the LU decomposition for solving systems of linear equations. 20 | 21 | The Cholesky decomposition of a Hermitian positive-definite matrix $A$, is a decomposition of the form 22 | 23 | $${\displaystyle \mathbf {A} =\mathbf {LL} ^{*},}$$ 24 | 25 | where $L$ is a lower triangular matrix with real and positive diagonal entries, and $L^{*}$ denotes the conjugate transpose of $L$. Every Hermitian positive-definite matrix (and thus also every real-valued symmetric positive-definite matrix) has a unique Cholesky decomposition. When $A$ is a real matrix (hence symmetric positive-definite), the factorization may be written 26 | 27 | $${\displaystyle \mathbf {A} =\mathbf {LL} ^{\mathsf {T}},}$$ 28 | 29 | where $L$ is a real lower triangular matrix with positive diagonal entries. 30 | 31 | 32 | ```{r, results='asis'} 33 | cho.mat <- chol(params$mat) 34 | 35 | L <- t(cho.mat) 36 | Lt <- t(L) 37 | 38 | cat( 39 | str_c( 40 | "$$ A = ", 41 | matrix2latex(L), 42 | " \\times ", 43 | matrix2latex(Lt), 44 | "$$" 45 | ) 46 | ) 47 | ``` 48 | 49 | Source https://en.wikipedia.org/wiki/Cholesky_decomposition 50 | 51 | 52 | -------------------------------------------------------------------------------- /matrix-decompositions/server.R: -------------------------------------------------------------------------------- 1 | # input <- list( 2 | # matrix = "1,2,3,2,4,6,3,3,3", 3 | # nrows = 3, 4 | # decomposition = "qr" 5 | # ) 6 | 7 | shinyServer(function(input, output) { 8 | 9 | vector <- reactive({ 10 | 11 | vector <- input$matrix %>% 12 | str_split("\\,") %>% 13 | unlist() %>% 14 | as.numeric() 15 | 16 | vector 17 | 18 | }) 19 | 20 | matrixA <- reactive({ 21 | 22 | vector <- vector() 23 | 24 | matrixA <- matrix( 25 | vector, 26 | nrow = input$nrows, 27 | ncol = input$nrows, 28 | byrow = TRUE 29 | ) 30 | 31 | matrixA 32 | 33 | }) 34 | 35 | output$matrix_render <- renderUI({ 36 | 37 | vector <- vector() 38 | matrixA <- matrixA() 39 | 40 | warning_msg <- NULL 41 | 42 | if(length(vector)%%input$nrows != 0) { 43 | 44 | warning_msg <- str_glue( 45 | "Data length {length(vector)} is not a sub-multiple or multiple of the number of rows {input$nrows}. Recycling vector elements." 46 | ) 47 | 48 | } else if ( length(vector) < input$nrows**2 ) { 49 | 50 | warning_msg <- str_glue( 51 | "Only first {input$nrows**2} given values will be used." 52 | ) 53 | 54 | } 55 | 56 | tagList( 57 | withMathJax(), 58 | str_c("$$ A = ", matrix2latex(matrixA), "$$"), 59 | if(!is.null(warning_msg)) tags$small(tags$i(class = "text-warning", warning_msg)) 60 | ) 61 | 62 | }) 63 | 64 | output$decomposition_output <- renderUI({ 65 | 66 | matrixA <- matrixA() 67 | 68 | file <- here(str_c("rmd/", input$decomposition, ".Rmd")) 69 | 70 | message(file) 71 | 72 | withMathJax( 73 | HTML( 74 | readLines( 75 | rmarkdown::render( 76 | input = file, 77 | output_format = "html_fragment", 78 | output_file = "temp.html", 79 | quiet = TRUE, 80 | params = list(mat = matrixA) 81 | ), 82 | encoding = "UTF-8" 83 | ) 84 | ) 85 | ) 86 | 87 | 88 | }) 89 | 90 | }) 91 | -------------------------------------------------------------------------------- /matrix-decompositions/rmd/svd.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "svd" 3 | output: html_document 4 | params: 5 | mat: !r matrix(c(1, 2, 3, 4), ncol = 2) 6 | editor_options: 7 | chunk_output_type: console 8 | --- 9 | 10 | ```{r, include=FALSE} 11 | # params <- list(mat = matrix(c(1, 2, 3, 4), ncol = 2)) 12 | library(stringr) 13 | knitr::opts_chunk$set(echo = FALSE) 14 | source(here::here("helpers.R")) 15 | ``` 16 | 17 |

Singular value decomposition

18 | 19 | SVD (Singular Value Decomposition) stands for splitting a matrix $A$ into a product $A=U \Sigma V^{T}$ where $U$ and $V$ are unitary matrices and $\Sigma$ is a diagonal matrix consisting of singular values on its main diagonal arranged in non-increasing order where all the singular values are non-negative. 20 | 21 | Mathematical applications of the SVD include computing the pseudoinverse, matrix approximation, and determining the rank, range, and null space of a matrix. The SVD is also extremely useful in all areas of science, engineering, and statistics, such as signal processing, least squares fitting of data, and process control. 22 | 23 | 24 | ```{r, results='asis'} 25 | svd.mat <- svd(params$mat) 26 | 27 | # svd.mat$u %*% diag(svd.mat$d) %*% t(svd.mat$v) 28 | 29 | U <- svd.mat$u 30 | S <- diag(svd.mat$d) 31 | Vt <- t(svd.mat$v) 32 | 33 | Uf <- round(U, 5) 34 | Sf <- round(S, 5) 35 | Vtf <- round(Vt, 5) 36 | 37 | # params$mat - (svd.mat$u %*% diag(svd.mat$d) %*% t(svd.mat$v)) 38 | 39 | cat( 40 | str_c( 41 | "$$ A = ", 42 | matrix2latex(Uf), 43 | " \\times ", 44 | matrix2latex(Sf), 45 | " \\times ", 46 | matrix2latex(Vtf), 47 | "$$" 48 | ) 49 | ) 50 | ``` 51 | 52 | Check $UU^{\mathrm {T} }= VV^{\mathrm {T} } = I$: 53 | 54 | ```{r, results='asis'} 55 | UUt <- U %*% t(U) 56 | UUtf <- round(UUt, 5) 57 | 58 | cat( 59 | str_c( 60 | "$$ UU^{\\mathrm {T}} = ", 61 | matrix2latex(Uf), 62 | " \\times ", 63 | matrix2latex(t(Uf)), 64 | " = ", 65 | matrix2latex(UUtf), 66 | "$$" 67 | ) 68 | ) 69 | ``` 70 | 71 | ```{r, results='asis'} 72 | VVt <- t(Vt) %*% Vt 73 | VVtf <- round(VVt, 5) 74 | 75 | cat( 76 | str_c( 77 | "$$ VV^{\\mathrm {T}} = ", 78 | matrix2latex(t(Vtf)), 79 | " \\times ", 80 | matrix2latex(Vtf), 81 | " = ", 82 | matrix2latex(VVtf), 83 | "$$" 84 | ) 85 | ) 86 | ``` 87 | 88 | 89 | Sources: 90 | 91 | - https://en.wikipedia.org/wiki/Singular_value_decomposition 92 | - https://r-snippets.readthedocs.io/en/latest/la/svd.html 93 | 94 | 95 | -------------------------------------------------------------------------------- /matrix-decompositions/rmd/temp.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 |

5 | Singular value decomposition 6 |

7 |

SVD (Singular Value Decomposition) stands for splitting a matrix 8 | \(A\) into a product \(A=U \Sigma V^{T}\) where \(U\) and \(V\) are unitary matrices and \(\Sigma\) is a diagonal matrix consisting of 9 | singular values on its main diagonal arranged in non-increasing order 10 | where all the singular values are non-negative.

11 |

Mathematical applications of the SVD include computing the 12 | pseudoinverse, matrix approximation, and determining the rank, range, 13 | and null space of a matrix. The SVD is also extremely useful in all 14 | areas of science, engineering, and statistics, such as signal 15 | processing, least squares fitting of data, and process control.

16 |

\[ A = \begin{pmatrix}-0.16301 & 17 | -0.21273 & 0.96342\\-0.45732 & -0.84895 & -0.26483\\0.87423 18 | & -0.48376 & 0.0411\end{pmatrix} \times \begin{pmatrix}123.47723 19 | & 0 & 0\\0 & 15.50396 & 0\\0 & 0 & 20 | 0.0188\end{pmatrix} \times \begin{pmatrix}-0.16301 & -0.45732 & 21 | 0.87423\\-0.21273 & -0.84895 & -0.48376\\0.96342 & -0.26483 22 | & 0.0411\end{pmatrix}\]

23 |

Check \(UU^{\mathrm {T} }= VV^{\mathrm {T} 24 | } = I\):

25 |

\[ UU^{\mathrm {T}} = 26 | \begin{pmatrix}-0.16301 & -0.21273 & 0.96342\\-0.45732 & 27 | -0.84895 & -0.26483\\0.87423 & -0.48376 & 28 | 0.0411\end{pmatrix} \times \begin{pmatrix}-0.16301 & -0.45732 & 29 | 0.87423\\-0.21273 & -0.84895 & -0.48376\\0.96342 & -0.26483 30 | & 0.0411\end{pmatrix} = \begin{pmatrix}1 & 0 & 0\\0 & 1 31 | & 0\\0 & 0 & 1\end{pmatrix}\]

32 |

\[ VV^{\mathrm {T}} = 33 | \begin{pmatrix}-0.16301 & -0.21273 & 0.96342\\-0.45732 & 34 | -0.84895 & -0.26483\\0.87423 & -0.48376 & 35 | 0.0411\end{pmatrix} \times \begin{pmatrix}-0.16301 & -0.45732 & 36 | 0.87423\\-0.21273 & -0.84895 & -0.48376\\0.96342 & -0.26483 37 | & 0.0411\end{pmatrix} = \begin{pmatrix}1 & 0 & 0\\0 & 1 38 | & 0\\0 & 0 & 1\end{pmatrix}\]

39 |

Sources:

40 | 44 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Shiny apps for educational purposes 2 | ================ 3 | 4 | - [FOA: ♫ Tell me *Y* ♪](#foa--tell-me-y-) 5 | - [Using apps locally](#using-apps-locally) 6 | - [Shiny apps](#shiny-apps) 7 | - [ARMA Process](#arma-process) 8 | - [Bias Variance](#bias-variance) 9 | - [Decision Tree](#decision-tree) 10 | - [Kmeans](#kmeans) 11 | - [Kmeans Images](#kmeans-images) 12 | - [Logistic Regression](#logistic-regression) 13 | - [Lorenz Attractor](#lorenz-attractor) 14 | - [Matrix Decompositions](#matrix-decompositions) 15 | 16 | ## FOA: ♫ Tell me *Y* ♪ 17 | 18 | The ideas/purposes behind every shiny app in this repository are: 19 | 20 | - Being a complement for a ML, Statistics, Probability, R class. The 21 | application mainly shows and exemplifies a *result* that needs to be 22 | explained. By themselves, the apps are just an app. 23 | - Point out other resources and links that are more formal and/or 24 | useful. 25 | - TBD. 26 | 27 | ![](screenshots.gif) 28 | 29 | ## Using apps locally 30 | 31 | There is a script `run_app.R` which contanins a helper function to 32 | download the repo in a temporal folder and then you can run the apps 33 | 34 | To load that function: 35 | 36 | ``` r 37 | source("https://raw.githubusercontent.com/jbkunst/shiny-apps-edu/master/run_app.R") 38 | ``` 39 | 40 | Then you can use it giving the folder name, for example: 41 | 42 | ``` r 43 | run_app("kmeans") 44 | ``` 45 | 46 | ## Shiny apps 47 | 48 | ### ARMA Process 49 | 50 | ![](arma-process/screenshot.png) Source code [here](/arma-process). See 51 | the live version in 52 | [shinyapps.io](https://jbkunst.shinyapps.io/arma-process). Go to 53 | [index](#shiny-apps-for-educational-purposes). 54 | 55 | ### Bias Variance 56 | 57 | ![](bias-variance/screenshot.png) Source code [here](/bias-variance). 58 | See the live version in 59 | [shinyapps.io](https://jbkunst.shinyapps.io/bias-variance). Go to 60 | [index](#shiny-apps-for-educational-purposes). 61 | 62 | ### Decision Tree 63 | 64 | ![](decision-tree/screenshot.png) Source code [here](/decision-tree). 65 | See the live version in 66 | [shinyapps.io](https://jbkunst.shinyapps.io/decision-tree). Go to 67 | [index](#shiny-apps-for-educational-purposes). 68 | 69 | ### Kmeans 70 | 71 | ![](kmeans/screenshot.png) Source code [here](/kmeans). See the live 72 | version in [shinyapps.io](https://jbkunst.shinyapps.io/kmeans). Go to 73 | [index](#shiny-apps-for-educational-purposes). 74 | 75 | ### Kmeans Images 76 | 77 | ![](kmeans-images/screenshot.png) Source code [here](/kmeans-images). 78 | See the live version in 79 | [shinyapps.io](https://jbkunst.shinyapps.io/kmeans-images). Go to 80 | [index](#shiny-apps-for-educational-purposes). 81 | 82 | ### Logistic Regression 83 | 84 | ![](logistic-regression/screenshot.png) Source code 85 | [here](/logistic-regression). See the live version in 86 | [shinyapps.io](https://jbkunst.shinyapps.io/logistic-regression). Go to 87 | [index](#shiny-apps-for-educational-purposes). 88 | 89 | ### Lorenz Attractor 90 | 91 | ![](lorenz-attractor/screenshot.png) Source code 92 | [here](/lorenz-attractor). See the live version in 93 | [shinyapps.io](https://jbkunst.shinyapps.io/lorenz-attractor). Go to 94 | [index](#shiny-apps-for-educational-purposes). 95 | 96 | ### Matrix Decompositions 97 | 98 | ![](matrix-decompositions/screenshot.png) Source code 99 | [here](/matrix-decompositions). See the live version in 100 | [shinyapps.io](https://jbkunst.shinyapps.io/matrix-decompositions). Go 101 | to [index](#shiny-apps-for-educational-purposes). 102 | -------------------------------------------------------------------------------- /readme.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Shiny apps for educational purposes" 3 | output: 4 | github_document: 5 | toc: true 6 | editor_options: 7 | chunk_output_type: console 8 | --- 9 | 10 | ```{r setup, include=FALSE} 11 | knitr::opts_chunk$set(echo = FALSE) 12 | library(tidyverse) 13 | library(shiny) 14 | library(callr) 15 | library(webshot2) 16 | # remotes::install_github("rstudio/webshot2") 17 | ``` 18 | 19 | ## FOA: ♫ Tell me _Y_ ♪ 20 | 21 | The ideas/purposes behind every shiny app in this repository are: 22 | 23 | - Being a complement for a ML, Statistics, Probability, R class. 24 | The application mainly shows and exemplifies a _result_ that needs to be explained. 25 | By themselves, the apps are just an app. 26 | - Point out other resources and links that are more formal and/or useful. 27 | - TBD. 28 | 29 | ![](screenshots.gif) 30 | 31 | 32 | ## Using apps locally 33 | 34 | There is a script `run_app.R` which contanins a helper function to download the repo in a temporal folder and then you can run the apps 35 | 36 | To load that function: 37 | 38 | ```{r, echo=TRUE, eval=FALSE} 39 | source("https://raw.githubusercontent.com/jbkunst/shiny-apps-edu/master/run_app.R") 40 | ``` 41 | 42 | Then you can use it giving the folder name, for example: 43 | 44 | ```{r, echo=TRUE, eval=FALSE} 45 | run_app("kmeans") 46 | ``` 47 | 48 | 49 | ## Shiny apps 50 | 51 | ```{r generate_screenshots, include=FALSE} 52 | apps <- dir() |> 53 | str_subset("\\.", negate = TRUE) 54 | 55 | apps_valid <- map(apps, dir) |> 56 | map(str_detect, "ui.R|server.R|app.Rmd|app.R") |> 57 | map_lgl(any) 58 | 59 | apps <- apps[apps_valid] 60 | apps <- setdiff(apps, c("binary-predictions-metrics")) 61 | 62 | dir(full.names = TRUE, recursive = TRUE) |> 63 | str_subset("screenshot.png") |> 64 | fs::file_delete() 65 | 66 | purrr::walk(apps, function(app = "matrix-decompositions"){ 67 | # app <- "arma-process" 68 | # app <- "kmeans-images" 69 | 70 | cli::cli_progress_step(app) 71 | 72 | fout <- fs::path(app, "screenshot", ext = "png") 73 | 74 | if(file.exists(fout)) return(TRUE) 75 | 76 | webshot2::appshot(app, file = fout, delay = 10) 77 | 78 | # app_rmd <- fs::path(app, "app", ext = "Rmd") 79 | # port <- sample(1000:9999, size = 1) 80 | # p <- callr::r_bg( 81 | # function(app, port) rmarkdown::run(app, shiny_args = list(port = port)), 82 | # args = list(app = app_rmd, port = port) 83 | # ) 84 | # webshot2::webshot(url = str_glue("http://127.0.0.1:{ port }/app.Rmd"), file = fout, delay = 15) 85 | # p$finalize() 86 | 87 | }) 88 | ``` 89 | 90 | ```{r, include=FALSE} 91 | screenshots <- dir(full.names = TRUE, recursive = TRUE) |> 92 | str_subset("screenshot.png") |> 93 | map(magick::image_read) |> 94 | reduce(magick::image_join) |> 95 | magick::image_animate(fps = 0.5) 96 | 97 | # screenshots 98 | magick::image_write(screenshots, path = "screenshots.gif") 99 | ``` 100 | 101 | 102 | ```{r generate_md, results='asis'} 103 | walk(apps, function(app = "kmeans-images"){ 104 | 105 | cat("\n") 106 | 107 | app_ttl <- app |> 108 | str_replace_all("-", " ") |> 109 | str_to_title() |> 110 | str_replace("Arma ", "ARMA ") 111 | 112 | cat(str_glue("### { app_ttl }")) 113 | 114 | cat("\n") 115 | 116 | cat(str_glue("![]({app}/screenshot.png)")) 117 | 118 | cat("\n") 119 | 120 | cat(str_glue("Source code [here](/{ app }).")) 121 | 122 | cat("\n") 123 | 124 | cat(str_glue("See the live version in [shinyapps.io](https://jbkunst.shinyapps.io/{ app }).")) 125 | 126 | cat("\n") 127 | 128 | cat("Go to [index](#shiny-apps-for-educational-purposes).") 129 | 130 | cat("\n") 131 | 132 | 133 | }) 134 | ``` 135 | 136 | -------------------------------------------------------------------------------- /binary-predictions-metrics/app.R: -------------------------------------------------------------------------------- 1 | # packages ---------------------------------------------------------------- 2 | library(shiny) 3 | library(bslib) 4 | library(dplyr) 5 | library(stringr) 6 | library(purrr) 7 | library(tibble) 8 | library(markdown) 9 | library(highcharter) 10 | 11 | # theme options ----------------------------------------------------------- 12 | apptheme <- bs_theme() 13 | 14 | sidebar <- purrr::partial(bslib::sidebar, width = 300) 15 | 16 | card <- purrr::partial(bslib::card, full_screen = TRUE) 17 | 18 | options( 19 | highcharter.theme = hc_theme( 20 | chart = list(style = list(fontFamily = "system-ui")), 21 | legend = list(itemStyle = list(fontWeight = "normal")), 22 | xAxis = list(gridLineWidth = 1), 23 | colors = unname(bs_get_variables(apptheme, c("primary", "danger", "success", "warning", "info", "secondary"))) 24 | ) 25 | ) 26 | 27 | # data -------------------------------------------------------------------- 28 | credit_data <- modeldata::credit_data |> 29 | as_tibble() |> 30 | rename_all(str_to_lower) |> 31 | select(status, where(is.numeric)) |> 32 | 33 | # avoid logscale problems 34 | filter(debt > 1) |> 35 | 36 | # fewer points 37 | group_by(status) |> 38 | sample_n(200) |> 39 | 40 | ungroup() 41 | 42 | # credit_data |> count(status) 43 | 44 | # ui ---------------------------------------------------------------------- 45 | ui <- page_fillable( 46 | theme = apptheme, 47 | padding = 0, 48 | layout_sidebar( 49 | fillable = TRUE, 50 | sidebar = sidebar( 51 | title = "Binary predicctions", 52 | withMathJax(), 53 | selectInput("variable", tags$small("Variable"), choices = names(credit_data)[-1]), 54 | checkboxInput("logscale", tags$small("Log-scale on \\(x\\)-axis")), 55 | tags$small(htmltools::includeMarkdown("readme.md")) 56 | ), 57 | layout_column_wrap( 58 | width = 1/2, 59 | height = "60%", 60 | card(highchartOutput("hcpoints")) 61 | ), 62 | layout_column_wrap( 63 | width = 1/4, 64 | height = "40%", 65 | card( 66 | # card_header(uiOutput("iter")), 67 | # card_body(plotOutput("iter_plot")) 68 | ) 69 | ) 70 | ) 71 | ) 72 | 73 | # server ------------------------------------------------------------------ 74 | server <- function(input, output, session) { 75 | 76 | # input <- list(variable = "time"); input 77 | 78 | data <- reactive({ 79 | set.seed(123) 80 | data <- credit_data |> 81 | select(status, variable = !!input$variable) |> 82 | mutate( 83 | jitter = rbeta(n(), shape1 = 5, shape2 = 5), 84 | jitter = round(jitter, 3), 85 | id = row_number() 86 | ) 87 | data 88 | }) 89 | 90 | output$hcpoints <- renderHighchart({ 91 | 92 | varname <- isolate(input$variable) 93 | 94 | data <- isolate(data()) 95 | datas <- data |> 96 | ungroup() |> 97 | group_nest(status) |> 98 | mutate(data = map(data, select, x = variable, y = jitter, id)) |> 99 | deframe() 100 | 101 | highchart() |> 102 | hc_yAxis(visible = FALSE) |> 103 | hc_xAxis(title = list(text = varname)) |> 104 | hc_add_series(name = "good", id = "good", data = datas[["good"]], type = "scatter") |> 105 | hc_add_series(name = "bad", id = "bad", data = datas[["bad"]], type = "scatter") 106 | }) 107 | 108 | # update scatter/jitter 109 | observe({ 110 | 111 | invalidateLater(1000) 112 | 113 | data <- data() 114 | 115 | datas <- data |> 116 | group_by(status) |> 117 | group_nest() |> 118 | mutate( 119 | data = map(data, select, x = variable, y = jitter, id), 120 | data = map(data, list_parse) 121 | ) |> 122 | deframe() 123 | 124 | highchartProxy("hcpoints") |> 125 | hcpxy_update_series(id = "good", data = datas[["good"]]) |> 126 | hcpxy_update_series(id = "bad", data = datas[["bad"]]) |> 127 | hcpxy_update( 128 | xAxis = list( 129 | type = ifelse(input$logscale, "logarithmic", "linear"), 130 | title = list(text = str_to_title(input$variable)) 131 | ) 132 | ) 133 | 134 | }) |> bindEvent(c(input$variable, input$logscale)) 135 | 136 | 137 | } 138 | 139 | shinyApp(ui, server) 140 | -------------------------------------------------------------------------------- /lorenz-attractor/app.R: -------------------------------------------------------------------------------- 1 | # packages ---------------------------------------------------------------- 2 | library(shiny) 3 | library(bslib) 4 | library(plotly) 5 | library(ggplot2) 6 | library(dplyr) 7 | library(markdown) 8 | 9 | # theme options ----------------------------------------------------------- 10 | apptheme <- bs_theme() 11 | 12 | sidebar <- purrr::partial(bslib::sidebar, width = 300) 13 | 14 | card <- purrr::partial(bslib::card, full_screen = TRUE) 15 | 16 | thematic::thematic_shiny(font = "auto") 17 | 18 | theme_set(theme_minimal() + theme(legend.position = "none")) 19 | 20 | # app options ------------------------------------------------------------- 21 | generate_lorenz <- function(sigma = 10, rho = 28, beta = 8/3, 22 | start = c(1, 1, 1), n = 1000, dt = 0.01) { 23 | x <- y <- z <- numeric(n) 24 | x[1] <- start[1] 25 | y[1] <- start[2] 26 | z[1] <- start[3] 27 | 28 | for (i in 2:n) { 29 | dx <- sigma * (y[i-1] - x[i-1]) 30 | dy <- x[i-1] * (rho - z[i-1]) - y[i-1] 31 | dz <- x[i-1] * y[i-1] - beta * z[i-1] 32 | 33 | x[i] <- x[i-1] + dx * dt 34 | y[i] <- y[i-1] + dy * dt 35 | z[i] <- z[i-1] + dz * dt 36 | } 37 | 38 | data.frame(x = x, y = y, z = z, time = 1:n) 39 | } 40 | 41 | # ui --------------------------------------------------------------------- 42 | ui <- page_fillable( 43 | theme = apptheme, 44 | padding = 0, 45 | layout_sidebar( 46 | fillable = TRUE, 47 | sidebar = sidebar( 48 | title = "Lorenz System Parameters", 49 | withMathJax(), 50 | sliderInput("sigma", "\\( \\sigma \\) (sigma):", 51 | min = 1, max = 20, value = 10, step = 0.1), 52 | sliderInput("rho", "\\( \\rho \\) (rho):", 53 | min = 1, max = 50, value = 28, step = 0.1), 54 | sliderInput("beta", "\\( \\beta \\) (beta):", 55 | min = 0.1, max = 10, value = 8/3, step = 0.1), 56 | numericInput("n_points", "Number of points:", 57 | value = 1000, min = 100, max = 5000), 58 | numericInput("dt", "Time step (dt):", 59 | value = 0.01, min = 0.001, max = 0.1, step = 0.001), 60 | tags$small(htmltools::includeMarkdown("readme.md")) 61 | ), 62 | layout_columns( 63 | col_widths = c(12, 4, 4, 4), 64 | row_heights = c(3, 2), 65 | card( 66 | card_header("3D Lorenz Attractor"), 67 | plotlyOutput("lorenz3d", height = "100%") 68 | ), 69 | card( 70 | card_header("X-Y Projection"), 71 | plotOutput("xy_plot") 72 | ), 73 | card( 74 | card_header("X-Z Projection"), 75 | plotOutput("xz_plot") 76 | ), 77 | card( 78 | card_header("Y-Z Projection"), 79 | plotOutput("yz_plot") 80 | ) 81 | ) 82 | ) 83 | ) 84 | 85 | # server ----------------------------------------------------------------- 86 | server <- function(input, output, session) { 87 | 88 | lorenz_data <- reactive({ 89 | generate_lorenz( 90 | sigma = input$sigma, 91 | rho = input$rho, 92 | beta = input$beta, 93 | n = input$n_points, 94 | dt = input$dt 95 | ) 96 | }) 97 | 98 | output$lorenz3d <- renderPlotly({ 99 | df <- lorenz_data() 100 | 101 | plot_ly(df, x = ~x, y = ~y, z = ~z, type = 'scatter3d', mode = 'lines', 102 | line = list(width = 2, color = ~time, colorscale = 'Viridis')) %>% 103 | layout(scene = list( 104 | xaxis = list(title = "X"), 105 | yaxis = list(title = "Y"), 106 | zaxis = list(title = "Z") 107 | )) 108 | }) 109 | 110 | output$xy_plot <- renderPlot({ 111 | df <- lorenz_data() 112 | ggplot(df, aes(x = x, y = y, color = time)) + 113 | geom_path() + 114 | scale_color_viridis_c() + 115 | labs(title = "X-Y Projection") + 116 | coord_equal() 117 | }) 118 | 119 | output$xz_plot <- renderPlot({ 120 | df <- lorenz_data() 121 | ggplot(df, aes(x = x, y = z, color = time)) + 122 | geom_path() + 123 | scale_color_viridis_c() + 124 | labs(title = "X-Z Projection") + 125 | coord_equal() 126 | }) 127 | 128 | output$yz_plot <- renderPlot({ 129 | df <- lorenz_data() 130 | ggplot(df, aes(x = y, y = z, color = time)) + 131 | geom_path() + 132 | scale_color_viridis_c() + 133 | labs(title = "Y-Z Projection") + 134 | coord_equal() 135 | }) 136 | } 137 | 138 | shinyApp(ui, server) 139 | -------------------------------------------------------------------------------- /decision-tree/app.R: -------------------------------------------------------------------------------- 1 | # packages ---------------------------------------------------------------- 2 | library(shiny) 3 | library(bslib) 4 | library(tidyverse) 5 | library(scales) 6 | library(markdown) 7 | 8 | library(geomtextpath) # remotes::install_github("AllanCameron/geomtextpath") 9 | library(risk3r) # remotes::install_github("jbkunst/risk3r", force = TRUE) 10 | library(klassets) # remotes::install_github("jbkunst/klassets", force = TRUE) 11 | library(celavi) # remotes::install_github("jbkunst/celavi", force = TRUE) 12 | 13 | # theme options ----------------------------------------------------------- 14 | apptheme <- bs_theme() 15 | 16 | sidebar <- purrr::partial(bslib::sidebar, width = 300) 17 | 18 | card <- purrr::partial(bslib::card, full_screen = TRUE) 19 | 20 | thematic::thematic_shiny(font = "auto") 21 | 22 | theme_set(theme_minimal() + theme(legend.position = "bottom")) 23 | 24 | primary_color <- unname(bs_get_variables(apptheme, c("primary"))) 25 | 26 | # ui ---------------------------------------------------------------------- 27 | ui <- page_fillable( 28 | theme = apptheme, 29 | padding = 0, 30 | layout_sidebar( 31 | fillable = TRUE, 32 | sidebar = sidebar( 33 | title = "Decision Tree", 34 | withMathJax(), 35 | radioButtons( 36 | "relationship", 37 | tags$small("Relationship between \\(x\\), \\(y\\) and the response variable"), 38 | choices = list( 39 | "\\(x > y\\)" = "x > y", 40 | "\\(x^2 > y\\)" = "x^2 - y > 0", 41 | "\\(|x| > |y|\\)" = "abs(x) - abs(y) > 0", 42 | "\\(x^2 + y^2 < 0.5\\)" = "x^2 + y^2 < 0.5", 43 | "\\( \\sin(x \\cdot \\pi ) > \\sin(y \\cdot \\pi ) \\)" = "sin(x*pi) > sin(y*pi)" 44 | ) 45 | ), 46 | sliderInput( 47 | "percent_noise", 48 | tags$small("Percent noise"), 49 | min = 0, 50 | max = 50, 51 | step = 5, 52 | value = 20, 53 | post = "%" 54 | ), 55 | sliderInput( 56 | "depth", 57 | tags$small("Maximum depth of the tree"), 58 | min = 1, 59 | max = 8, 60 | step = 1, 61 | value = 2 62 | ), 63 | sliderInput( 64 | "alpha", 65 | tags$small("Significance level for variable selection \\( \\alpha \\)"), 66 | min = 0, 67 | max = 1, 68 | step = 0.05, 69 | value = .1 70 | ), 71 | sliderInput( 72 | "n", 73 | tags$small("Number of observartions"), 74 | min = 100, 75 | max = 1000, 76 | step = 100, 77 | value = 1000 78 | ), 79 | checkboxInput( 80 | "show_model_field", 81 | tags$small("Show model predicctions"), 82 | value = TRUE 83 | ), 84 | tags$small(htmltools::includeMarkdown("readme.md")) 85 | ), 86 | 87 | layout_columns( 88 | col_widths = c(6, 6, 4, 4, 4), 89 | row_heights = c(3, 2), 90 | card(card_body(plotOutput("join_dist", width = "100%", height = "100%"))), 91 | card(card_body(plotOutput("tree_plot", width = "100%", height = "100%"))), 92 | card(card_body(plotOutput("roc_plot", width = "100%", height = "100%"))), 93 | card(card_body(plotOutput("bg_plot", width = "100%", height = "100%"))), 94 | card(card_body(tableOutput("cross_table"))) 95 | ) 96 | ) 97 | ) 98 | 99 | # server ------------------------------------------------------------------ 100 | server <- function(input, output, session) { 101 | 102 | # input <- list( 103 | # n = 500, 104 | # relationship = "x > y", 105 | # show_model_field = TRUE, 106 | # show_xy_rel = TRUE, 107 | # percent_noise = 10, 108 | # depth = 8, 109 | # alpha = 0.05 110 | # ); input 111 | 112 | dxy <- reactive({ 113 | 114 | set.seed(1234) 115 | 116 | dxy <- klassets::sim_response_xy( 117 | n = input$n, 118 | x_dist = purrr::partial(runif, min = -1, max = 1), 119 | relationship = function(x, y) eval(parse(text = input$relationship)), 120 | noise = input$percent_noise/100 121 | ) 122 | 123 | dxy <- klassets::fit_classification_tree( 124 | dxy, 125 | maxdepth = input$depth, 126 | alpha = input$alpha 127 | ) 128 | 129 | dxy 130 | 131 | }) 132 | 133 | output$join_dist <- renderPlot({ 134 | 135 | dxy <- dxy() 136 | 137 | p <- ggplot() 138 | 139 | if (input$show_model_field) { 140 | p <- plot(dxy) 141 | } else { 142 | p <- klassets:::plot.klassets_response_xy(dxy) 143 | } 144 | 145 | p 146 | 147 | }) 148 | 149 | output$tree_plot <- renderPlot({ 150 | 151 | dxy <- dxy() 152 | 153 | plot(attr(dxy, "model")) 154 | 155 | }) 156 | 157 | output$roc_plot <- renderPlot({ 158 | 159 | dxy <- dxy() 160 | 161 | droc <- risk3r::roc_data( 162 | actual = as.numeric(dxy$response), 163 | predicted = 1 - dxy$prediction 164 | ) 165 | 166 | aucroc <- Metrics::auc( 167 | actual = as.numeric(dxy$response), 168 | predicted = dxy$prediction 169 | ) 170 | 171 | ggplot(droc) + 172 | geom_line(aes(x, y), linewidth = 2, color = primary_color) + 173 | labs(title = str_glue("AUC: { percent(aucroc) }")) + 174 | theme(legend.position = "none") + 175 | ggplot2::labs(x = "False positive rate (FPR)", 176 | y = "True positive rate (TPR)") 177 | 178 | }) 179 | 180 | output$bg_plot <- renderPlot({ 181 | 182 | dxy <- dxy() 183 | 184 | ksmod <- risk3r::ks( 185 | actual = as.numeric(dxy$response), 186 | predicted = 1 - dxy$prediction 187 | ) 188 | 189 | ggplot(dxy, aes(1 - prediction, group = response, fill = response, color = response, label = response)) + 190 | geom_density(alpha = 0.1, linewidth = 2) + 191 | 192 | scale_color_manual(name = NULL, values = c(muted("red", 35), muted("blue", 35))) + 193 | 194 | geom_textdensity(size = 4, fontface = 1, hjust = 0.2, vjust = -0.5) + 195 | scale_y_continuous(labels = NULL) + 196 | scale_x_continuous(limits = c(0, 1)) + 197 | labs(x = "Probability", y = "Density") + 198 | labs(title = str_glue("KS: { percent(ksmod) }")) + 199 | theme(legend.position = "none") 200 | 201 | }) 202 | 203 | output$cross_table <- renderTable({ 204 | 205 | dxy <- dxy() 206 | 207 | dxy2 <- klassets::fit_classification_tree( 208 | dxy, 209 | type = "response", 210 | maxdepth = input$depth, 211 | alpha = input$alpha 212 | ) 213 | 214 | dxy2 |> 215 | count(response, prediction) |> 216 | mutate( 217 | p = percent(n/sum(n)), 218 | n = comma(n), 219 | lbl = str_glue("{n} ({p})"), 220 | prediction = str_glue("pred: {prediction}"), 221 | response = str_glue("response: {response}") 222 | ) |> 223 | select(-n, -p) |> 224 | spread(prediction, lbl) |> 225 | rename(` ` = response) 226 | 227 | }) 228 | 229 | } 230 | 231 | shinyApp(ui, server) 232 | -------------------------------------------------------------------------------- /logistic-regression/app.R: -------------------------------------------------------------------------------- 1 | # packages ---------------------------------------------------------------- 2 | library(shiny) 3 | library(bslib) 4 | library(tidyverse) 5 | library(scales) 6 | library(markdown) 7 | library(broom) 8 | library(metR) 9 | library(scales) 10 | library(patchwork) 11 | library(geomtextpath) # remotes::install_github("AllanCameron/geomtextpath") 12 | library(risk3r) # remotes::install_github("jbkunst/risk3r", force = TRUE) 13 | library(klassets) # remotes::install_github("jbkunst/klassets", force = TRUE) 14 | # library(celavi) # remotes::install_github("jbkunst/celavi", force = TRUE) 15 | 16 | # theme options ----------------------------------------------------------- 17 | apptheme <- bs_theme() 18 | 19 | sidebar <- purrr::partial(bslib::sidebar, width = 300) 20 | 21 | card <- purrr::partial(bslib::card) 22 | 23 | thematic::thematic_shiny(font = "auto") 24 | 25 | theme_set(theme_minimal() + theme(legend.position = "bottom")) 26 | 27 | primary_color <- unname(bs_get_variables(apptheme, c("primary"))) 28 | 29 | # ui ---------------------------------------------------------------------- 30 | ui <- page_fillable( 31 | theme = apptheme, 32 | padding = 0, 33 | layout_sidebar( 34 | fillable = TRUE, 35 | sidebar = sidebar( 36 | title = "Logistic Regression", 37 | withMathJax(), 38 | radioButtons( 39 | "relationship", 40 | tags$small("Relationship between \\(x\\), \\(y\\) and the response variable"), 41 | choices = list( 42 | "\\(x > y\\)" = "x > y", 43 | "\\(x^2 > y\\)" = "x^2 - y > 0", 44 | "\\(|x| > |y|\\)" = "abs(x) - abs(y) > 0", 45 | "\\(x^2 + y^2 < 0.5\\)" = "x^2 + y^2 < 0.5", 46 | "\\( \\sin(x \\cdot \\pi ) > \\sin(y \\cdot \\pi ) \\)" = "sin(x*pi) > sin(y*pi)" 47 | ) 48 | ), 49 | sliderInput( 50 | "percent_noise", 51 | tags$small("Percent noise"), 52 | min = 0, 53 | max = 50, 54 | step = 5, 55 | value = 20, 56 | post = "%" 57 | ), 58 | sliderInput( 59 | "order", 60 | tags$span("Model Order"), 61 | min = 1, 62 | max = 4, 63 | step = 1, 64 | value = 1 65 | ), 66 | sliderInput( 67 | "n", 68 | tags$small("Number of observartions"), 69 | min = 100, 70 | max = 1000, 71 | step = 100, 72 | value = 1000 73 | ), 74 | checkboxInput( 75 | "apply_stepwise", 76 | tags$small("Apply stepwise"), 77 | value = FALSE 78 | ), 79 | checkboxInput( 80 | "show_model_field", 81 | tags$small("Show model predicctions"), 82 | value = TRUE 83 | ), 84 | tags$small(htmltools::includeMarkdown("readme.md")) 85 | ), 86 | 87 | layout_columns( 88 | col_widths = c(6, 6, 4, 4, 4), 89 | row_heights = c(3, 2), 90 | card(card_body(plotOutput("join_dist", width = "100%", height = "100%"))), 91 | card(card_body(plotOutput("marginal_dist", width = "100%", height = "100%"))), 92 | card(card_body(plotOutput("roc_plot", width = "100%", height = "100%"))), 93 | card(card_body(plotOutput("bg_plot", width = "100%", height = "100%"))), 94 | card(card_body(tableOutput("coef_table"))) 95 | ) 96 | ) 97 | ) 98 | 99 | # server ------------------------------------------------------------------ 100 | server <- function(input, output, session) { 101 | 102 | # input <- list( 103 | # n = 500, 104 | # relationship = "x > y", 105 | # show_model_field = TRUE, 106 | # show_xy_rel = TRUE, 107 | # percent_noise = 10, 108 | # order = 8, 109 | # apply_stepwise = TRUE 110 | # ); input 111 | 112 | dxy <- reactive({ 113 | 114 | dxy <- klassets::sim_response_xy( 115 | n = input$n, 116 | x_dist = purrr::partial(runif, min = -1, max = 1), 117 | relationship = function(x, y) eval(parse(text = input$relationship)), 118 | noise = input$percent_noise/100 119 | ) 120 | 121 | dxy <- klassets::fit_logistic_regression( 122 | dxy, 123 | order = input$order, 124 | stepwise = input$apply_stepwise 125 | ) 126 | 127 | dxy 128 | 129 | }) 130 | 131 | output$join_dist <- renderPlot({ 132 | 133 | dxy <- dxy() 134 | 135 | p <- ggplot() 136 | 137 | if (input$show_model_field) { 138 | p <- plot(dxy) 139 | 140 | } else { 141 | p <- klassets:::plot.klassets_response_xy(dxy) 142 | 143 | } 144 | 145 | p 146 | 147 | }) 148 | 149 | output$marginal_dist <- renderPlot({ 150 | 151 | dxy <- dxy() 152 | 153 | # dxy <- dxy |> 154 | # mutate(pred = predict(mod, newdata = dxy, type = "response")) 155 | 156 | dg <- dxy |> 157 | select(x, y, response) |> 158 | gather(key, value, -response) |> 159 | mutate(key = str_glue("variable {key}")) |> 160 | mutate(response = as.logical(response)) 161 | 162 | p <- ggplot() + 163 | # data 164 | geom_point( 165 | data = dg, 166 | aes(value, as.numeric(response), color = factor(response), shape = factor(response)), 167 | size = 3, 168 | alpha = 0.5, 169 | position = position_jitter(height = 0.05) 170 | ) + 171 | 172 | scale_shape_manual(name = NULL, values = c(1, 4)) + 173 | scale_color_manual(name = NULL, values = c(muted("blue"), muted("red"))) + 174 | 175 | scale_y_continuous( 176 | breaks = c(0, 1), 177 | labels = c("FALSE\n(response = 0)", "TRUE\n(response = 1)") 178 | ) + 179 | 180 | # predictions 181 | 182 | # geom_smooth( 183 | # color = primary_color, size = 1.2, alpha = 0.1, 184 | # method = "loess", formula = y ~ x 185 | # ) + 186 | 187 | labs( 188 | x = NULL, 189 | y = NULL 190 | ) + 191 | 192 | facet_wrap(vars(key)) 193 | 194 | if(input$show_model_field) { 195 | 196 | dg2 <- dxy |> 197 | select(x, y, prediction) |> 198 | gather(key, value, -prediction) |> 199 | mutate(key = str_glue("variable {key}")) 200 | 201 | p <- p + 202 | geom_smooth( 203 | data = dg2, 204 | aes(value, prediction), 205 | method = "loess", 206 | formula = y ~ x, 207 | color = primary_color 208 | ) 209 | 210 | } 211 | 212 | p 213 | 214 | }) 215 | 216 | output$roc_plot <- renderPlot({ 217 | 218 | dxy <- dxy() 219 | 220 | droc <- risk3r::roc_data( 221 | actual = as.numeric(dxy$response), 222 | predicted = dxy$prediction 223 | ) 224 | 225 | aucroc <- Metrics::auc( 226 | actual = as.numeric(dxy$response), 227 | predicted = dxy$prediction 228 | ) 229 | 230 | ggplot(droc) + 231 | geom_line(aes(x, y), linewidth = 2, color = primary_color) + 232 | labs(title = str_glue("AUC: { percent(aucroc) }")) + 233 | theme(legend.position = "none") + 234 | ggplot2::labs(x = "False positive rate (FPR)", 235 | y = "True positive rate (TPR)") 236 | 237 | }) 238 | 239 | output$bg_plot <- renderPlot({ 240 | 241 | dxy <- dxy() 242 | 243 | ksmod <- risk3r::ks( 244 | actual = as.numeric(dxy$response), 245 | predicted = 1 - dxy$prediction 246 | ) 247 | 248 | ggplot(dxy, aes(1 - prediction, group = response, fill = response, color = response, label = response)) + 249 | geom_density(alpha = 0.1, linewidth = 2) + 250 | 251 | scale_color_manual(name = NULL, values = c(muted("red", 35), muted("blue", 35))) + 252 | 253 | geom_textdensity(size = 4, fontface = 1, hjust = 0.2, vjust = -0.5) + 254 | scale_y_continuous(labels = NULL) + 255 | scale_x_continuous(limits = c(0, 1)) + 256 | labs(x = "Probability", y = "Density") + 257 | labs(title = str_glue("KS: { percent(ksmod) }")) + 258 | theme(legend.position = "none") 259 | 260 | }) 261 | 262 | output$coef_table <- renderTable({ 263 | 264 | dxy <- dxy() 265 | 266 | mod <- attr(dxy, "model") 267 | 268 | dmod <- tidy(mod) |> 269 | mutate( 270 | term = str_replace_all(term, "_", "^"), 271 | ` ` = symnum(p.value, corr = FALSE, na = FALSE, legend = FALSE, 272 | cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), 273 | symbols = c("***", "**", "*", ".", " ")) 274 | ) 275 | 276 | dmod 277 | 278 | }) 279 | 280 | } 281 | 282 | shinyApp(ui, server) 283 | -------------------------------------------------------------------------------- /arma-process/app.R: -------------------------------------------------------------------------------- 1 | # packages ---------------------------------------------------------------- 2 | library(shiny) 3 | library(bslib) 4 | library(tidyverse) 5 | library(highcharter) 6 | library(markdown) 7 | 8 | # theme options ----------------------------------------------------------- 9 | apptheme <- bs_theme() 10 | 11 | sidebar <- purrr::partial(bslib::sidebar, width = 300) 12 | 13 | card <- purrr::partial(bslib::card, full_screen = TRUE) 14 | 15 | options( 16 | highcharter.theme = hc_theme( 17 | chart = list(style = list(fontFamily = "system-ui")), 18 | legend = list(itemStyle = list(fontWeight = "normal")), 19 | xAxis = list(gridLineWidth = 1), 20 | colors = unname(bs_get_variables(apptheme, c("primary", "danger", "success", "warning", "info", "secondary"))) 21 | ) 22 | ) 23 | 24 | # app options ------------------------------------------------------------- 25 | LAG_MAX <- 10 26 | STR_OBS <- 20 27 | NOBS <- 5000 28 | AR <- 0.0 29 | MA <- 0.20 30 | SEED <- 123 31 | DURATION <- 100 # needs to be <= than min refresh interval 32 | 33 | # start chart 34 | set.seed(SEED) 35 | 36 | ts_aux <- arima.sim(model = list(ar = AR, ma = MA), n = STR_OBS) 37 | 38 | teoACF <- as.numeric(ARMAacf(ar = AR, ma = MA, lag.max = LAG_MAX, pacf = FALSE)) 39 | smpACF <- as.numeric(acf(ts_aux, lag.max = LAG_MAX, plot = TRUE)$acf) 40 | 41 | # plot(smpACF, ylim = c(-1, 1)) 42 | # lines(teoACF) 43 | 44 | teoPACF <- as.numeric(ARMAacf(ar = AR, ma = MA, lag.max = LAG_MAX, pacf = TRUE)) 45 | smpPACF <- as.numeric(pacf(ts_aux, lag.max = LAG_MAX, plot = TRUE)$acf) 46 | 47 | # plot(smpPACF, ylim = c(-1, 1)) 48 | # lines(teoPACF) 49 | 50 | # ui ---------------------------------------------------------------------- 51 | ui <- page_fillable( 52 | theme = apptheme, 53 | padding = 0, 54 | layout_sidebar( 55 | fillable = TRUE, 56 | sidebar = sidebar( 57 | title = "ARMA model Simulation", 58 | sliderInput("ar", "AR", -.9, .9, value = AR, 0.05, width = "100%"), 59 | sliderInput("ma", "MA", -.9, .9, value = MA, 0.05, width = "100%"), 60 | sliderInput("interval", "Refresh (secs.)", 0.5, 2, value = 1, step = 0.5, width = "100%"), 61 | tags$small(htmltools::includeMarkdown("readme.md")) 62 | ), 63 | 64 | layout_columns( 65 | col_widths = c(12, 6, 6), 66 | row_heights = c(3, 2), 67 | card(card_header(uiOutput("model", inline = TRUE)), card_body(highchartOutput("ts"))), 68 | card(card_header("ACF"), card_body(highchartOutput("acf"))), 69 | card(card_header("PACF"), card_body(highchartOutput("pacf"))) 70 | ) 71 | ) 72 | ) 73 | 74 | # server ------------------------------------------------------------------ 75 | server <- function(input, output, session) { 76 | 77 | # input <- list(ar = AR, ma = MA); input 78 | 79 | value <- reactiveVal(STR_OBS) 80 | 81 | ts <- reactive({ 82 | 83 | value(STR_OBS) 84 | 85 | # input <- list(ar = 0.9, ma = 0.1, nobs = 200) 86 | set.seed(SEED) 87 | 88 | ts <- arima.sim(model = list(ar = input$ar, ma = input$ma), n = NOBS) 89 | 90 | }) 91 | 92 | output$model <- renderUI({ 93 | 94 | arp <- ifelse(input$ar != 0, paste0(input$ar, " \\times X_{t-1}"), "") 95 | map <- ifelse(input$ma != 0, paste0(" + ", input$ma, " \\times \\epsilon_{t-1}"), "") 96 | 97 | mod <- paste0("X_{t} = ", 98 | arp, 99 | ifelse(input$ar != 0, " + ", ""), 100 | "\\epsilon_t", 101 | map 102 | ) 103 | 104 | mod <- paste0("$$", mod, "$$") 105 | 106 | tags$small(tags$p(withMathJax(mod))) 107 | 108 | }) 109 | 110 | output$ts <- renderHighchart({ 111 | 112 | ts <- ts() 113 | 114 | df <- data.frame(x = 1:STR_OBS, y = head(ts, STR_OBS)) 115 | 116 | hchart( 117 | df, 118 | "line", 119 | id = "ts", 120 | name = "Time series", 121 | marker = list(enabled = FALSE), 122 | animation = list(duration = DURATION), 123 | tooltip = list(valueDecimals = 3) 124 | ) |> 125 | hc_navigator( 126 | enabled = TRUE, 127 | series = list(type = "line"), 128 | xAxis = list(labels = list(enabled = FALSE)) 129 | ) |> 130 | hc_yAxis_multiples( 131 | # default axis 132 | list(title = list(text = "")), 133 | list( 134 | title = list(text = ""), 135 | linkedTo = 0, 136 | opposite = TRUE, 137 | tickPositioner = JS( 138 | "function(min,max){ 139 | var data = this.chart.yAxis[0].series[0].processedYData; 140 | //last point 141 | return [Math.round(1000 * data[data.length-1])/1000]; 142 | }" 143 | ) 144 | ) 145 | ) 146 | 147 | }) 148 | 149 | observeEvent(ts(), { 150 | 151 | # if ts change redraw the teo ACF 152 | ts <- ts() 153 | 154 | cli::cli_inform(input$ar) 155 | cli::cli_inform(input$ma) 156 | 157 | teoACF <- as.numeric( 158 | ARMAacf( 159 | # ar = 0.2, 160 | # ma = 0.2, 161 | ar = ifelse(!is.null(input$ar), input$ar, AR), 162 | ma = ifelse(!is.null(input$ma), input$ar, MA), 163 | lag.max = LAG_MAX, 164 | pacf = FALSE 165 | ) 166 | ) 167 | 168 | smpACF <- as.numeric(acf(head(ts, STR_OBS), lag.max = LAG_MAX, plot = FALSE)$acf) 169 | 170 | highchartProxy("acf") |> 171 | hcpxy_update_series(id = "tacf", data = teoACF) |> 172 | hcpxy_update_series(id = "sacf", data = smpACF) 173 | 174 | teoPACF <- as.numeric( 175 | ARMAacf( 176 | # ar = 0.2, 177 | # ma = 0.2, 178 | ar = ifelse(!is.null(input$ar), input$ar, AR), 179 | ma = ifelse(!is.null(input$ma), input$ar, MA), 180 | lag.max = LAG_MAX, 181 | pacf = TRUE 182 | ) 183 | ) 184 | 185 | smpPACF <- as.numeric(pacf(head(ts, STR_OBS), lag.max = LAG_MAX, plot = FALSE)$acf) 186 | 187 | highchartProxy("pacf") |> 188 | hcpxy_update_series(id = "tpacf", data = teoPACF) |> 189 | hcpxy_update_series(id = "spacf", data = smpPACF) 190 | 191 | }) 192 | 193 | observe({ 194 | 195 | interval <- max(as.numeric(input$interval), 0.25) 196 | 197 | invalidateLater(1000 * interval, session) 198 | 199 | # animation <- ifelse(interval < 0.5, FALSE, TRUE) 200 | animation <- TRUE 201 | 202 | value_to_add <- isolate(value()) + 1 203 | # value_to_add <- 11 204 | value(value_to_add) 205 | 206 | ts <- ts() 207 | 208 | smpACF <- as.numeric(acf(head(ts, value_to_add), lag.max = LAG_MAX, plot = FALSE)$acf) 209 | 210 | highchartProxy("acf") |> 211 | hcpxy_update_series(id = "sacf", data = smpACF) 212 | 213 | highchartProxy("ts") |> 214 | hcpxy_add_point( 215 | id = "ts", 216 | point = list(x = value_to_add, y = ts[value_to_add]), 217 | animation = animation 218 | ) 219 | 220 | }) 221 | 222 | output$acf <- renderHighchart({ 223 | 224 | highchart() |> 225 | hc_chart(type = "column") |> 226 | hc_yAxis(min = -1, max = 1) |> 227 | hc_add_series( 228 | data = smpACF, 229 | id = "sacf", 230 | name = "Estimated" 231 | ) |> 232 | hc_add_series( 233 | data = teoACF, 234 | id = "tacf", 235 | name = "Theoretical" 236 | ) |> 237 | hc_tooltip( 238 | table = TRUE, 239 | headerFormat = "Lag {point.key}", 240 | valueDecimals = 3 241 | ) |> 242 | hc_plotOptions( 243 | series = list( 244 | pointWidth = 5, 245 | animation = list(duration = DURATION), 246 | marker = list(symbol = "circle") 247 | ) 248 | ) 249 | 250 | }) 251 | 252 | output$pacf <- renderHighchart({ 253 | 254 | highchart() |> 255 | hc_chart(type = "column") |> 256 | hc_yAxis(min = -1, max = 1) |> 257 | hc_add_series( 258 | data = smpPACF, 259 | id = "spacf", 260 | name = "Estimated" 261 | ) |> 262 | hc_add_series( 263 | data = teoPACF, 264 | id = "tpacf", 265 | name = "Theoretical" 266 | ) |> 267 | hc_tooltip( 268 | table = TRUE, 269 | headerFormat = "Lag {point.key}
", 270 | valueDecimals = 3 271 | ) |> 272 | hc_plotOptions( 273 | series = list( 274 | pointStart = 1, 275 | pointWidth = 5, 276 | animation = list(duration = DURATION), 277 | marker = list(symbol = "circle") 278 | ) 279 | ) 280 | }) 281 | 282 | } 283 | 284 | shinyApp(ui, server) 285 | -------------------------------------------------------------------------------- /kmeans-images/app.R: -------------------------------------------------------------------------------- 1 | # packages ---------------------------------------------------------------- 2 | library(shiny) 3 | library(bslib) 4 | library(tidyverse) 5 | library(scales) 6 | library(jpeg) 7 | library(imager) 8 | # library(threejs) # devtools::install_github("bwlewis/rthreejs") 9 | library(plotly) 10 | library(markdown) # htmltools::includeMarkdown 11 | library(shinyWidgets) 12 | 13 | # theme options ----------------------------------------------------------- 14 | thematic::thematic_shiny(font = "auto") 15 | 16 | theme_set(theme_minimal() + theme(legend.position = "bottom")) 17 | 18 | apptheme <- bs_theme() 19 | 20 | sidebar <- purrr::partial(bslib::sidebar, width = 300) 21 | 22 | card <- purrr::partial(bslib::card, full_screen = TRUE) 23 | 24 | # app options ------------------------------------------------------------- 25 | img_choices <- setNames( 26 | dir("www/imgs/", full.names = TRUE), 27 | str_to_title(gsub("\\.jpg$|\\.jpeg$|", "", dir("www/imgs/"))) 28 | ) 29 | 30 | # ui ---------------------------------------------------------------------- 31 | ui <- page_fillable( 32 | theme = apptheme, 33 | padding = 0, 34 | layout_sidebar( 35 | fillable = TRUE, 36 | sidebar = sidebar( 37 | title = "K-means on images", 38 | withMathJax(), 39 | selectizeInput( 40 | "image_file", 41 | tags$span("Image"), 42 | choices = sample(img_choices), 43 | width = "100%" 44 | ), 45 | shinyWidgets::sliderTextInput( 46 | "k", 47 | tags$span("Parameter \\(k\\) for \\(K\\)-Means"), 48 | grid = TRUE, 49 | force_edges = TRUE, 50 | selected = 6, 51 | choices = c(1:10, 20, 50, 100, 500) 52 | ), 53 | checkboxInput("use_xy", tags$small("Use pixel position for clustering \\((r_i, g_i, b_i, x_i, y_i)\\)")), 54 | checkboxInput("scale", tags$small("Scale to \\([0, 1]\\) all columns before kmeans")), 55 | checkboxInput("show_axes", tags$small("Show image axes")), 56 | tags$small(htmltools::includeMarkdown("readme.md")) 57 | ), 58 | 59 | layout_columns( 60 | col_widths = 4, 61 | row_heights = 1, 62 | card( 63 | card_header("Image"), 64 | card_body(plotOutput("originalImage")) 65 | ), 66 | card( 67 | card_header("Color distribution"), 68 | card_body(plotOutput("originalColorDist")) 69 | ), 70 | card( 71 | card_header(tags$small("3D Scatter plot of sample of pixels")), 72 | card_body(plotlyOutput("scatterplot3d")) 73 | ), 74 | card( 75 | card_header("Result Image"), 76 | card_body(plotOutput("resultImage")) 77 | ), 78 | card( 79 | card_header("Result color distribution"), 80 | card_body(plotOutput("resultColorDist")) 81 | ), 82 | card( 83 | card_header(tags$small("3D Scatter plot from result image")), 84 | card_body(plotlyOutput("scatterplot3dresults")) 85 | ) 86 | ) 87 | ) 88 | ) 89 | 90 | # server ------------------------------------------------------------------ 91 | server <- function(input, output, session) { 92 | 93 | # input <- list( 94 | # image_file = "imgs/chess.jpg", 95 | # k = 4, 96 | # use_xy = FALSE, 97 | # scale = FALSE, 98 | # show_axes = FALSE 99 | # ); input 100 | # 101 | # input <- list( 102 | # image_file = sample(img_choices, 1), 103 | # k = sample(1:10, size = 1), 104 | # use_xy = TRUE, 105 | # scale = FALSE, 106 | # show_axes = FALSE 107 | # ); input 108 | 109 | image <- reactive({ 110 | 111 | # image <- readJPEG(input$image_file) 112 | 113 | image <- load.image(here::here(input$image_file)) 114 | image 115 | 116 | }) 117 | 118 | df_image <- reactive({ 119 | 120 | # image <- image() 121 | 122 | image <- readJPEG(input$image_file) 123 | 124 | cli::cli_alert_info("processing image {input$image_file}") 125 | 126 | df_image <- map(1:3, function(i) image[,,i]) %>% 127 | map(function(m) { 128 | # m <- matrix(round(runif(12), 2), nrow = 4) 129 | m |> 130 | as.data.frame() |> 131 | as_tibble() |> 132 | mutate(y = row_number()) |> 133 | gather(x, c, -y) |> 134 | mutate( 135 | x = as.numeric(gsub("V", "", x)), 136 | y = rev(y) 137 | ) |> 138 | select(x, y, c) 139 | }) %>% 140 | reduce(left_join, by = c("x", "y")) %>% 141 | rename(r = c.x, g = c.y, b = c) %>% 142 | mutate(rgb = rgb(r, g, b)) 143 | 144 | df_image 145 | 146 | }) 147 | 148 | df_image_kmeans <- reactive({ 149 | 150 | cli::cli_inform("running stats::kmeans") 151 | 152 | df_image <- df_image() 153 | 154 | df_image_input <- df_image |> 155 | select(r, g, b, x, y) 156 | 157 | if(!input$use_xy) { 158 | df_image_input <- df_image_input |> 159 | select(-x, -y) 160 | } 161 | 162 | if(input$scale){ 163 | df_image_input <- df_image_input |> 164 | mutate(across(everything(), .fns = ~ scales::rescale(.x, to = c(0, 1)))) 165 | } 166 | 167 | kMeans <- kmeans(df_image_input, centers = as.integer(input$k)) 168 | 169 | df_image_kmeans <- df_image %>% 170 | mutate( 171 | rgb_app= rgb(kMeans$centers[kMeans$cluster, c("r", "g", "b")]) 172 | ) 173 | 174 | df_image_kmeans2 <- df_image_kmeans |> 175 | pull(rgb_app) |> 176 | # head() |> 177 | col2rgb() |> 178 | t() |> 179 | as_tibble() |> 180 | mutate(across(everything(), ~ ./255)) |> 181 | set_names(c("r", "g", "b")) |> 182 | rename_with(~ str_c(., "_app"), .cols = everything()) 183 | 184 | df_image_kmeans <- bind_cols(df_image_kmeans, df_image_kmeans2) 185 | 186 | df_image_kmeans 187 | 188 | }) 189 | 190 | output$originalImage <- renderPlot({ 191 | 192 | # df_image <- df_image() 193 | # 194 | # plot( 195 | # df_image$x, 196 | # df_image$y, 197 | # col = df_image$rgb, 198 | # asp = 1, 199 | # pch = ".", 200 | # ylab = "", 201 | # xlab = "", 202 | # xaxt = "n", 203 | # yaxt = "n", 204 | # axes = TRUE 205 | # ) 206 | 207 | image <- image() 208 | 209 | plot(image, axes = input$show_axes) 210 | 211 | }) 212 | 213 | output$originalColorDist <- renderPlot({ 214 | 215 | df_image <- df_image() 216 | 217 | daux <- df_image %>% 218 | count(rgb) |> 219 | arrange(desc(n)) |> 220 | mutate( 221 | rgb = fct_inorder(rgb), 222 | rgb = fct_lump_n(rgb, n = 20, w = n) 223 | ) |> 224 | count(rgb, wt = n) |> 225 | mutate(proportion = n/sum(n)) 226 | 227 | cols <- daux |> 228 | mutate( 229 | col = as.character(rgb), 230 | col = ifelse(col == "Other", "transparent", col), 231 | ) |> 232 | select(rgb, col) |> 233 | deframe() 234 | 235 | cols 236 | 237 | ggplot(daux) + 238 | geom_bar(aes(y = fct_rev(rgb), x = proportion, fill = rgb), color = "grey90", stat = "identity") + 239 | scale_fill_manual(values = cols, guide = "none") + 240 | # scale_x_continuous(labels = scales::percent) + 241 | scale_x_sqrt(labels = scales::percent) + 242 | labs(x = NULL, y = NULL) 243 | 244 | }) 245 | 246 | output$scatterplot3d <- renderPlotly({ 247 | 248 | df_image <- df_image() 249 | 250 | set.seed(123) 251 | 252 | daux <- df_image |> 253 | sample_n(1000) |> 254 | mutate(across(c(r,g, b), function(x) round(x, 2))) |> 255 | mutate(label = sprintf("rgb (%s, %s, %s)", r, g, b)) 256 | 257 | plot_ly( 258 | data = daux, 259 | x = ~r, 260 | y = ~g, 261 | z = ~b, 262 | type = "scatter3d", 263 | mode = "markers", 264 | marker = list( 265 | color = ~rgb, # Assuming `rgb` is in a format compatible with plotly, e.g., hex colors 266 | symbol = "circle" 267 | ), 268 | text = ~label # Tooltip text 269 | ) 270 | 271 | 272 | }) 273 | 274 | output$resultImage <- renderPlot({ 275 | 276 | df_image_kmeans <- df_image_kmeans() 277 | image <- image() 278 | 279 | daux <- df_image_kmeans |> 280 | mutate(y = max(y) - y + 1) |> 281 | filter(TRUE) |> 282 | mutate() 283 | 284 | image_result <- image 285 | 286 | image_result[,,,1] <- daux |> select(x, y, r_app) |> spread(y, r_app) |> select(-x) |> as.matrix() 287 | image_result[,,,2] <- daux |> select(x, y, g_app) |> spread(y, g_app) |> select(-x) |> as.matrix() 288 | image_result[,,,3] <- daux |> select(x, y, b_app) |> spread(y, b_app) |> select(-x) |> as.matrix() 289 | 290 | plot(image_result, axes = input$show_axes) 291 | 292 | # plot( 293 | # df_image_kmeans$x, 294 | # df_image_kmeans$y, 295 | # col = df_image_kmeans$rgb_app, 296 | # asp = 1, 297 | # pch = ".", 298 | # ylab = "", 299 | # xlab = "", 300 | # xaxt = "n", 301 | # yaxt = "n", 302 | # input$show_axes 303 | # ) 304 | 305 | }) 306 | 307 | output$resultColorDist <- renderPlot({ 308 | 309 | df_image_kmeans <- df_image_kmeans() 310 | 311 | daux <- df_image_kmeans %>% 312 | count(rgb = rgb_app) |> 313 | arrange(desc(n)) |> 314 | mutate( 315 | rgb = fct_inorder(rgb), 316 | rgb = fct_lump_n(rgb, n = 20, w = n) 317 | ) |> 318 | count(rgb, wt = n) |> 319 | mutate(proportion = n/sum(n)) 320 | 321 | cols <- daux |> 322 | mutate( 323 | col = as.character(rgb), 324 | col = ifelse(col == "Other", "transparent", col), 325 | ) |> 326 | select(rgb, col) |> 327 | deframe() 328 | 329 | cols 330 | 331 | ggplot(daux) + 332 | geom_bar(aes(y = fct_rev(rgb), x = proportion, fill = rgb), color = "grey90", stat = "identity") + 333 | scale_fill_manual(values = cols, guide = "none") + 334 | scale_x_continuous(labels = scales::percent) + 335 | labs(x = NULL, y = NULL) 336 | }) 337 | 338 | output$scatterplot3dresults <- renderPlotly({ 339 | 340 | df_image_kmeans <- df_image_kmeans() 341 | 342 | set.seed(123) 343 | 344 | daux <- df_image_kmeans |> 345 | sample_n(1000) |> 346 | mutate(across(c(r,g, b), function(x) round(x, 2))) |> 347 | mutate(across(c(r_app, g_app, b_app), function(x) round(x, 2))) |> 348 | mutate( 349 | label = sprintf("rgb (%s, %s, %s)", r, g, b), 350 | label_app = sprintf("rgb (%s, %s, %s)", r_app, g_app, b_app), 351 | ) 352 | 353 | plot_ly( 354 | data = daux, 355 | x = ~r, 356 | y = ~g, 357 | z = ~b, 358 | type = "scatter3d", 359 | mode = "markers", 360 | marker = list( 361 | color = ~rgb_app, # Assuming `rgb` is in a format compatible with plotly, e.g., hex colors 362 | symbol = "circle" 363 | ), 364 | text = ~ glue::glue("{label_app}\n{label}")# Tooltip text 365 | ) 366 | 367 | }) 368 | 369 | } 370 | 371 | shinyApp(ui, server) 372 | -------------------------------------------------------------------------------- /kmeans/app.R: -------------------------------------------------------------------------------- 1 | # packages ---------------------------------------------------------------- 2 | library(shiny) 3 | library(bslib) 4 | library(tidyverse) 5 | library(klassets) # remotes::install_github("jbkunst/klassets") 6 | library(markdown) 7 | library(ggforce) 8 | library(deldir) 9 | 10 | # theme options ----------------------------------------------------------- 11 | thematic::thematic_shiny(font = "auto") 12 | 13 | theme_set(theme_minimal() + theme(legend.position = "bottom")) 14 | 15 | apptheme <- bs_theme() 16 | 17 | sidebar <- purrr::partial(bslib::sidebar, width = 300) 18 | 19 | card <- purrr::partial(bslib::card, full_screen = TRUE) 20 | 21 | primary_color <- unname(bs_get_variables(apptheme, c("primary"))) 22 | 23 | # app options ------------------------------------------------------------- 24 | KMAX <- 5 25 | 26 | # ui ---------------------------------------------------------------------- 27 | ui <- page_fillable( 28 | theme = apptheme, 29 | padding = 0, 30 | layout_sidebar( 31 | fillable = TRUE, 32 | sidebar = sidebar( 33 | title = "K-means", 34 | withMathJax(), 35 | # tags$style(type = "text/css", ".irs-grid-pol.small {height: 0px;}"), 36 | 37 | # "Algorithm parameters", 38 | sliderInput( 39 | "k", tags$small("Parameter \\(k\\) for \\(K\\)-Means"), value = 4, min = 2, max = KMAX, ticks = TRUE 40 | ), 41 | # shinyWidgets::sliderTextInput( 42 | sliderInput( 43 | "iter", 44 | tags$small("Iterations of algorithm"), 45 | # choices = 0:15, 46 | min = 1, max = 15, 47 | ticks = FALSE, 48 | value = 4, 49 | animate = animationOptions(interval = 3000) 50 | ), 51 | accordion( 52 | multiple = FALSE, 53 | open = FALSE, 54 | accordion_panel( 55 | "Simulate data", 56 | sliderInput( 57 | "n_groups", tags$small("Number of groups to simulate"), value = 3, min = 1, max = KMAX 58 | ), 59 | sliderInput( 60 | "n", tags$small("Number of points to simulate"), value = 200, min = 100, max = 500, step = 100 61 | ), 62 | actionButton("button", "Generate", class = "btn-primary btn-sm") 63 | ) 64 | ), 65 | tags$small(htmltools::includeMarkdown("readme.md")) 66 | ), 67 | 68 | layout_columns( 69 | col_widths = c(12, 3, 3, 3, 3), 70 | row_heights = c(3, 2), 71 | card(card_header(uiOutput("iter")), card_body(plotOutput("iter_plot"))), 72 | card(card_body(tableOutput("iter_table"))), 73 | card(card_body(plotOutput("wc"))), 74 | card(card_body(plotOutput("convergence"))), 75 | card(card_body(plotOutput("elbow"))) 76 | ) 77 | ) 78 | ) 79 | 80 | # server ------------------------------------------------------------------ 81 | server <- function(input, output, session) { 82 | 83 | # input <- list(n_groups = 4, n = 150, k = 3, iter = 2); input 84 | # input <- list(n_groups = 3, n = 500, k = 5, iter = 2); input 85 | # input <- list(n_groups = 3, n = 200, k = 4, iter = 2); input 86 | 87 | output$iter <- renderUI({ 88 | str_glue("Iteration #{input$iter}: {input$k} means ({input$n_groups} groups)") 89 | }) 90 | 91 | data <- reactive({ 92 | 93 | input$button 94 | 95 | set.seed(123) 96 | 97 | data <- klassets::sim_groups(n = isolate(input$n), groups = isolate(input$n_groups)) 98 | 99 | data 100 | 101 | }) 102 | 103 | # k means iterations all 104 | kmi_all <- reactive({ 105 | 106 | data <- data() 107 | 108 | showNotification(str_glue("Calculating internal iterations")) 109 | 110 | kmi_all <- map(1:KMAX, function(k){ 111 | cli::cli_inform(str_glue("{k} centers")) 112 | klassets::kmeans_iterations(df = data, centers = k) 113 | }) 114 | 115 | kmi_all 116 | 117 | }) 118 | 119 | # k means iteration (for actual selected k) 120 | kmi <- reactive({ 121 | 122 | kmi_all <- kmi_all() 123 | 124 | kmi <- kmi_all[[input$k]] 125 | 126 | updateSliderInput( 127 | inputId = "iter", 128 | max = max(kmi$centers$iteration), 129 | # value = 1 130 | value = sample(1:max(kmi$center$iteration), size = 1) 131 | ) 132 | 133 | kmi 134 | 135 | }) 136 | 137 | # kmi_plot <- reactive({ 138 | # 139 | # kmi <- kmi() 140 | # 141 | # kmi_plot <- plot(kmi) 142 | # 143 | # kmi_plot 144 | # 145 | # }) 146 | 147 | data_hist_all <- reactive({ 148 | 149 | kmi_all <- kmi_all() 150 | 151 | ks <- 1:KMAX 152 | 153 | data_hist_all <- kmi_all |> 154 | map(pluck, "points") |> 155 | # map(filter, iteration == max(iteration)) |> 156 | # map(select, -iteration, -id) |> 157 | map2_df(ks, ~ mutate(.x, k = .y, .before = 1)) 158 | 159 | data_hist_all <- data_hist_all |> 160 | # filter(k == 2) |> 161 | # distance from cluster 162 | group_by(k, iteration, cluster) |> 163 | mutate(xc = mean(x), yc = mean(y)) |> 164 | mutate(dc = (x - xc)^2 + (y - yc)^2) |> 165 | # distance from total center 166 | ungroup() |> 167 | group_by(k, iteration) |> 168 | mutate(xt = mean(x), yt = mean(y)) |> 169 | mutate(dt = (x - xt)^2 + (y - yt)^2) |> 170 | ungroup() 171 | 172 | data_hist_all 173 | 174 | }) 175 | 176 | data_elbow <- reactive({ 177 | 178 | data_hist_all <- data_hist_all() 179 | 180 | data_elbow <- data_hist_all |> 181 | group_by(k, iteration) |> 182 | summarise(dc = sum(dc), dt = sum(dt), .groups = "drop") |> 183 | mutate(wc = 1 - dc/dt) |> 184 | ungroup() 185 | 186 | data_elbow 187 | 188 | }) 189 | 190 | output$iter_plot <- renderPlot({ 191 | 192 | # kmi_plot <- kmi_plot() 193 | # 194 | # kmi_plot + 195 | # ggforce::facet_wrap_paginate( 196 | # vars(iteration), 197 | # nrow = 1, 198 | # ncol = 1, 199 | # page = input$iter + 0 200 | # ) 201 | 202 | kmi <- kmi() 203 | 204 | dpoints <- kmi$points |> filter(iteration == input$iter) 205 | dcenters <- kmi$centers |> filter(iteration == input$iter - 1) 206 | 207 | # xmin, xmax, ymin, ymax. 208 | bnd <- dpoints |> 209 | summarise( 210 | x1 = min(pretty(dpoints$x)), 211 | x2 = max(pretty(dpoints$x)), 212 | y1 = min(pretty(dpoints$y)), 213 | y2 = max(pretty(dpoints$y)) 214 | ) |> 215 | pivot_longer(cols = everything()) |> 216 | pull(value) 217 | 218 | bnd 219 | 220 | k <- nrow(dplyr::count(dcenters, cluster)) 221 | colors <- viridisLite::viridis(k, begin = 0.1, end = 0.9) 222 | colors <- purrr::set_names(colors, LETTERS[seq_len(k)]) 223 | 224 | p <- ggplot() + 225 | ggforce::geom_voronoi_segment( 226 | data = dcenters, 227 | aes(cx, cy), 228 | alpha = 0.2, bound = bnd 229 | ) + 230 | geom_point( 231 | data = dpoints, 232 | aes(x, y, group = id, color = cluster, shape = group), 233 | size = 2#, alpha = 0.5 234 | ) + 235 | geom_point( 236 | data = dcenters, 237 | aes(cx, cy, group = cluster, fill = cluster), 238 | size = 7, alpha = 1, shape = 21, show.legend = FALSE, color = "white" 239 | ) + 240 | labs( 241 | shape = "Original\nGroup", 242 | color = "Assigned\nCluster", 243 | x = NULL, 244 | y = NULL 245 | ) + 246 | scale_color_manual(values = colors, name = "Assigned\nCluster", na.value = "gray70") + 247 | scale_fill_manual(values = colors, name = "Assigned\nCluster", na.value = "gray70") + 248 | theme(legend.position = "right") 249 | 250 | p 251 | 252 | }) 253 | 254 | output$iter_table <- renderTable({ 255 | 256 | kmi <- kmi() 257 | 258 | dpoints <- kmi$points |> filter(iteration == input$iter) 259 | 260 | dpoints |> 261 | count(group, cluster) |> 262 | mutate( 263 | group = str_glue("G{group}"), 264 | cluster = fct_na_value_to_level(cluster, "0"), 265 | cluster = str_glue("Clus{cluster}"), 266 | ) |> 267 | complete(group, cluster, fill = list(n = 0)) |> 268 | spread(group, n) |> 269 | rename(` ` = cluster) 270 | 271 | }, width = "100%") 272 | 273 | output$wc <- renderPlot({ 274 | 275 | data_hist_all <- data_hist_all() 276 | 277 | dwck <- data_hist_all |> 278 | filter(k == input$k) |> 279 | group_by(iteration, cluster) |> 280 | summarise(wck = sum(dc), .groups = "drop") 281 | 282 | k <- input$k 283 | colors <- viridisLite::viridis(k, begin = 0.1, end = 0.9) 284 | colors <- purrr::set_names(colors, LETTERS[seq_len(k)]) 285 | 286 | ggplot(dwck) + 287 | geom_vline(aes(xintercept = input$iter), linewidth = 3, alpha = 0.25, color = primary_color) + 288 | geom_col(aes(iteration, wck, fill = cluster), position = position_stack()) + 289 | scale_x_continuous(breaks = unique(dwck$iteration), minor_breaks = NULL) + 290 | scale_fill_manual(values = colors, name = "", na.value = "gray90") + 291 | labs(y = expression("Sum of W(C_k)")) + 292 | theme(legend.position = "none") 293 | 294 | }) 295 | 296 | output$convergence <- renderPlot({ 297 | 298 | data_elbow <- data_elbow() 299 | 300 | daux <- data_elbow |> 301 | filter(k == input$k, iteration > 0) |> 302 | ungroup() 303 | 304 | # ggplot(data_elbow, aes(iteration, 1 - wc)) + 305 | # geom_line(size = 1.2, color = "gray60") + 306 | # facet_wrap(vars(k)) + 307 | # scale_y_continuous(limits = c(0, 1)) 308 | 309 | ggplot(daux, aes(iteration, 1 - wc)) + 310 | geom_line(linewidth = 1.2, color = "gray60") + 311 | geom_point( 312 | data = filter(daux, iteration == input$iter), 313 | shape = 21, 314 | size = 5, 315 | color = "white", 316 | fill = primary_color 317 | ) + 318 | scale_x_continuous(breaks = daux$iteration, minor_breaks = NULL) + 319 | scale_y_continuous(limits = c(0, 1)) 320 | 321 | }) 322 | 323 | output$elbow <- renderPlot({ 324 | 325 | data_elbow <- data_elbow() 326 | 327 | daux <- data_elbow |> 328 | group_by(k) |> 329 | filter(iteration == max(iteration)) |> 330 | ungroup() 331 | 332 | # ggplot(data_elbow, aes(k, 1 - wc)) + 333 | # geom_line(size = 1.2, color = "gray60") + 334 | # # kunstomverse::geom_point2 335 | # geom_point( 336 | # data = filter(daux, k == input$k), 337 | # shape = 21, 338 | # size = 5, 339 | # color = "white", 340 | # fill = primary_color 341 | # ) + 342 | # scale_x_continuous(breaks = 1:10, minor_breaks = NULL) + 343 | # facet_wrap(vars(iteration)) 344 | 345 | 346 | ggplot(daux, aes(k, 1 - wc)) + 347 | geom_line(linewidth = 1.2, color = "gray60") + 348 | # kunstomverse::geom_point2 349 | geom_point( 350 | data = filter(daux, k == input$k), 351 | shape = 21, 352 | size = 5, 353 | color = "white", 354 | fill = primary_color 355 | ) + 356 | scale_x_continuous(breaks = 1:10, minor_breaks = NULL) + 357 | scale_y_continuous(limits = c(0, 1)) 358 | 359 | }) 360 | 361 | } 362 | 363 | shinyApp(ui, server) 364 | -------------------------------------------------------------------------------- /bias-variance/app.R: -------------------------------------------------------------------------------- 1 | # packages ---------------------------------------------------------------- 2 | library(shiny) 3 | library(bslib) 4 | library(tidyverse) 5 | library(highcharter) 6 | library(markdown) 7 | 8 | # theme options ----------------------------------------------------------- 9 | apptheme <- bs_theme() 10 | 11 | sidebar <- purrr::partial(bslib::sidebar, width = 300) 12 | 13 | card <- purrr::partial(bslib::card, full_screen = TRUE) 14 | 15 | options( 16 | highcharter.theme = hc_theme( 17 | chart = list(style = list(fontFamily = "system-ui")), 18 | legend = list(itemStyle = list(fontWeight = "normal")), 19 | colors = unname(bs_get_variables(apptheme, c("primary", "danger", "warning", "success", "info", "secondary"))), 20 | tooltip = list(valueDecimals = 3, shared = TRUE), 21 | xAxis = list(gridLineWidth = 1), 22 | plotOptions = list( 23 | spline = list(marker = list(enabled = FALSE, symbol = "cirlce")), 24 | line = list(marker = list(enabled = FALSE, symbol = "cirlce")), 25 | scatter = list( 26 | marker = list(symbol = "cirlce"), 27 | animation = list(duration = 100), 28 | events = list(legendItemClick = JS("function () { return false; }")) 29 | ) 30 | ), 31 | legend = list( 32 | # this for legendItemClick false 33 | itemStyle = list(cursor = "default"), 34 | # itemStyle = list(color = "#666666"), 35 | itemHiddenStyle = list(color = "#666666") 36 | # itemHoverStyle = list(color = "#666666") 37 | ) 38 | ) 39 | ) 40 | 41 | # app options ------------------------------------------------------------- 42 | metric <- Metrics::rmse 43 | 44 | ker <- function (u, kerntype = c("Gaussian", "Epanechnikov", "Quartic", 45 | "Triweight", "Triangular", "Uniform")) { 46 | kerntype = match.arg(kerntype) 47 | if (kerntype == "Gaussian") { 48 | result = 1/(sqrt(2 * pi)) * exp(-0.5 * (u^2)) 49 | } 50 | else { 51 | lenu = length(u) 52 | result = vector(, lenu) 53 | for (j in 1:lenu) { 54 | if (abs(u[j]) <= 1) { 55 | if (kerntype == "Epanechnikov") { 56 | result[j] = 3/4 * (1 - u[j]^2) 57 | } 58 | if (kerntype == "Quartic") { 59 | result[j] = 15/16 * ((1 - u[j]^2)^2) 60 | } 61 | if (kerntype == "Triweight") { 62 | result[j] = 35/32 * ((1 - u[j]^2)^3) 63 | } 64 | if (kerntype == "Triangular") { 65 | result[j] = (1 - abs(u[j])) 66 | } 67 | if (kerntype == "Uniform") { 68 | result[j] = 1/2 69 | } 70 | } 71 | else { 72 | result[j] = 0 73 | } 74 | } 75 | } 76 | return(result) 77 | } 78 | 79 | NadarayaWatsonkernel <- function (x, y, h, gridpoint){ 80 | 81 | n = length(y) 82 | mh = vector(, length(gridpoint)) 83 | for (j in 1:length(gridpoint)) { 84 | suma = sumb = vector(, n) 85 | for (i in 1:n) { 86 | suma[i] = ker((gridpoint[j] - x[i]) / h) * y[i] 87 | sumb[i] = ker((gridpoint[j] - x[i]) / h) 88 | } 89 | mh[j] = sum(suma) / sum(sumb) 90 | } 91 | 92 | return(list(gridpoint = gridpoint, mh = mh)) 93 | } 94 | 95 | 96 | 97 | # ui ---------------------------------------------------------------------- 98 | ui <- page_fillable( 99 | theme = apptheme, 100 | padding = 0, 101 | layout_sidebar( 102 | fillable = TRUE, 103 | sidebar = sidebar( 104 | title = "Bias & Variance", 105 | sliderInput( 106 | "bandwidth", 107 | tags$small("Model's bandwidth"), 108 | min = 0.1, 109 | max = 20, 110 | step = 1, 111 | value = 10 112 | ), 113 | sliderInput( 114 | "n", 115 | tags$small("Number of train observations"), 116 | min = 50, 117 | max = 100, 118 | step = 10, 119 | value = 50 120 | ), 121 | shiny::checkboxInput( 122 | "show_train", 123 | tags$small("Show train set information"), 124 | value = FALSE 125 | ), 126 | tags$small(htmltools::includeMarkdown("readme.md")) 127 | ), 128 | 129 | layout_columns( 130 | col_widths = c(12, 6, 6), 131 | row_heights = c(3, 2), 132 | card(card_body(highchartOutput("chartdata"))), 133 | card(card_body(highchartOutput("charterror"))), 134 | card(card_body(highchartOutput("chartbandwidth"))) 135 | ) 136 | ) 137 | ) 138 | 139 | # server ------------------------------------------------------------------ 140 | server <- function(input, output, session) { 141 | 142 | # input <- list(n = 100, bandwidth = 10) 143 | 144 | dxy <- reactive({ 145 | 146 | set.seed(1234) 147 | 148 | s <- seq(1:input$n)/input$n 149 | d <- max(diff(s)) 150 | 151 | # dxy <- tibble(x = c(s, s) + runif(2*input$n, -d/2 + d/2)) |> 152 | dxy <- tibble(x = c(s, s) + 0) |> 153 | mutate( 154 | x = scales::rescale(x, to = c(0, 100)), 155 | # e = rnorm(input$n * 2, sd = 10), 156 | y = x + 10 * sin(x / 5) + 20 * sin(x / 20) , 157 | y = y + rnorm(input$n * 2, sd = 10), 158 | s = ifelse(1:(2*input$n) <= input$n, "test", "train") 159 | ) 160 | 161 | # ggplot(dxy, aes(x, y, color = s)) + 162 | # geom_point() + 163 | # geom_smooth(span = 0.1) 164 | 165 | dxy 166 | 167 | }) 168 | 169 | dpred <- reactive({ 170 | 171 | dxy <- dxy() 172 | 173 | dxy_test <- dxy |> 174 | filter(s == "train") 175 | 176 | nwk <- NadarayaWatsonkernel( 177 | dxy_test$x, 178 | dxy_test$y, 179 | h = input$bandwidth, 180 | gridpoint = dxy_test$x 181 | # gridpoint = seq(0, 100, length.out = 100) 182 | ) 183 | 184 | dpred <- tibble(x = nwk$gridpoint, y = nwk$mh) 185 | 186 | # ksmooth 187 | # ksm <- ksmooth(dxy$x, dxy$y, "normal", bandwidth = input$span, n.points = 1000) 188 | # 189 | # dpred <- tibble(x = ksm$x, y = ksm$y) 190 | 191 | # loess 192 | # dpred <- dxy |> 193 | # filter(s == "train") |> 194 | # select(-s) 195 | # 196 | # dpred <- dpred |> 197 | # mutate(y = predict(loess_mod, newdata = dpred)) |> 198 | # arrange(x) 199 | 200 | dpred 201 | 202 | }) 203 | 204 | derr <- reactive({ 205 | 206 | dpred <- dpred() 207 | dxy <- dxy() 208 | 209 | derr <- dxy |> 210 | left_join(dpred, by = "x", suffix = c("_real", "_model")) |> 211 | group_by(s) |> 212 | summarise(error = metric(y_real, y_model)) 213 | 214 | derr 215 | 216 | }) 217 | 218 | # this is a generalization of dpred() and derr() 219 | derr_bw <- reactive({ 220 | 221 | dxy <- dxy() 222 | 223 | dxy_test <- dxy |> 224 | filter(s == "train") 225 | 226 | # this can have the same step that input$bandwidth 227 | sq <- c(0.1, seq(from = 1, to = 20, by = 1)) 228 | 229 | derr_bw <- map_df(sq, function(bw = 10){ 230 | 231 | nwk <- NadarayaWatsonkernel( 232 | dxy_test$x, 233 | dxy_test$y, 234 | h = bw, 235 | gridpoint = dxy_test$x 236 | ) 237 | 238 | dpred <- tibble(x = nwk$gridpoint, y = nwk$mh) 239 | 240 | derr <- dxy |> 241 | left_join(dpred, by = "x", suffix = c("_real", "_model")) |> 242 | group_by(s) |> 243 | summarise(error = metric(y_real, y_model)) 244 | 245 | derr |> 246 | mutate(bw = bw) 247 | 248 | }) 249 | 250 | # ggplot(derr_bw) + 251 | # geom_line(aes(bw, error, group = s, color = s)) 252 | 253 | derr_bw 254 | 255 | }) 256 | 257 | output$chartdata <- renderHighchart({ 258 | 259 | # isolate, so works only one time 260 | dpred <- isolate(dpred()) 261 | dxy <- isolate(dxy()) 262 | 263 | dxyg <- dxy |> 264 | group_nest(s) |> 265 | deframe() 266 | 267 | highchart() |> 268 | hc_chart(type = "scatter") |> 269 | 270 | hc_xAxis(title = list(text = "Variable X")) |> 271 | hc_yAxis(title = list(text = "Variable Y")) |> 272 | 273 | hc_add_series( 274 | data = list_parse2(dpred), 275 | id = "model", 276 | name = "Model", 277 | type = "line", 278 | zIndex = 3 279 | ) |> 280 | hc_add_series( 281 | data = list_parse2(dxyg$train), 282 | id = "train", 283 | name = "Train set", 284 | zIndex = 2 285 | ) |> 286 | hc_add_series( 287 | data = list_parse2(dxyg$test), 288 | id = "test", 289 | name = "Test set", 290 | visible = FALSE, 291 | showInLegend = FALSE, 292 | zIndex = 1 293 | ) 294 | 295 | }) 296 | 297 | observeEvent(c(input$n, input$bandwidth), { 298 | 299 | dpred <- dpred() 300 | dxy <- dxy() 301 | 302 | dxyg <- dxy |> 303 | group_nest(s) |> 304 | deframe() 305 | 306 | highchartProxy("chartdata") |> 307 | hcpxy_update_series(id = "train", data = list_parse2(dxyg$train)) |> 308 | hcpxy_update_series(id = "test", data = list_parse2(dxyg$test)) |> 309 | hcpxy_update_series(id = "model", data = list_parse2(dpred)) 310 | 311 | }) 312 | 313 | output$charterror <- renderHighchart({ 314 | 315 | # isolate, so works only one time 316 | derr <- isolate(derr()) 317 | 318 | derrl <- as.list(deframe(derr)) 319 | 320 | highchart() |> 321 | hc_chart(type = "column") |> 322 | hc_xAxis(title = list(text = "Dataset"), type = "category", categories = c("Train", "Test")) |> 323 | hc_yAxis(title = list(text = "Error"), max = 20) |> 324 | hc_plotOptions( 325 | series = list( 326 | # showInLegend = FALSE, 327 | stacking = "normal", 328 | minPointLength = 0, 329 | dataLabels = list( 330 | enabled = TRUE, 331 | formatter = JS("function () { return Highcharts.numberFormat(this.y, 3); }") 332 | ) 333 | ) 334 | ) |> 335 | # this series just for mantain order colors 336 | hc_add_series(data = c(NA), showInLegend = FALSE) |> 337 | hc_add_series(data = tibble(x = 0, y = derrl$train), id = "train", name = "Train") |> 338 | hc_add_series(data = tibble(x = 1, y = derrl$test), id = "test", name = "Test", 339 | visible = FALSE, showInLegend = FALSE,) 340 | 341 | }) 342 | 343 | observeEvent(c(input$n, input$bandwidth), { 344 | 345 | derr <- derr() 346 | 347 | derrl <- as.list(deframe(derr)) 348 | 349 | highchartProxy("charterror") |> 350 | hcpxy_update_series(id = "train", data = list_parse2(tibble(x = 0, y = derrl$train))) |> 351 | hcpxy_update_series(id = "test", data = list_parse2(tibble(x = 1, y = derrl$test))) 352 | 353 | }) 354 | 355 | output$chartbandwidth <- renderHighchart({ 356 | 357 | # isolate, so works only one time 358 | derr_bw <- isolate(derr_bw()) 359 | bw <- isolate(input$bandwidth) 360 | 361 | derr_bwg <- derr_bw |> 362 | rename(x = bw, y = error) |> 363 | dplyr::select(x, y, s) |> 364 | group_nest(s) |> 365 | deframe() 366 | 367 | highchart() |> 368 | hc_chart(type = "line") |> 369 | 370 | hc_xAxis(title = list(text = "Bandwidth")) |> 371 | hc_yAxis(title = list(text = "Error"), max = 20) |> 372 | 373 | hc_add_series( 374 | # type = "scatter", 375 | # tooltip = list(show = FALSE), 376 | enableMouseTracking = FALSE, 377 | data = list( 378 | list(x = bw, y = 0), 379 | list(x = bw, y = 20) 380 | ), 381 | showInLegend = TRUE, 382 | name = "Bandwidth", 383 | id = "bandwidth" 384 | ) |> 385 | 386 | hc_add_series( 387 | data = list_parse2(derr_bwg$train), 388 | id = "train", 389 | name = "Train set", 390 | zIndex = 2 391 | ) |> 392 | hc_add_series( 393 | data = list_parse2(derr_bwg$test), 394 | id = "test", 395 | name = "Test set", 396 | visible = FALSE, 397 | showInLegend = FALSE, 398 | zIndex = 1 399 | ) 400 | 401 | }) 402 | 403 | observeEvent(c(input$n, input$bandwidth), { 404 | 405 | derr_bw <- derr_bw() 406 | bw <- input$bandwidth 407 | 408 | derr_bwg <- derr_bw |> 409 | rename(x = bw, y = error) |> 410 | dplyr::select(x, y, s) |> 411 | group_nest(s) |> 412 | deframe() 413 | 414 | highchartProxy("chartbandwidth") |> 415 | hcpxy_update_series(id = "bandwidth", data = list(list(x = bw, y = 0), list(x = bw, y = 20))) |> 416 | hcpxy_update_series(id = "train", data = list_parse2(derr_bwg$train)) |> 417 | hcpxy_update_series(id = "test", data = list_parse2(derr_bwg$test)) 418 | 419 | }) 420 | 421 | observeEvent(input$show_train, { 422 | 423 | highchartProxy("chartdata") |> 424 | hcpxy_update_series(id = "test", visible = input$show_train, showInLegend = input$show_train) 425 | 426 | highchartProxy("charterror") |> 427 | hcpxy_update_series(id = "test", visible = input$show_train, showInLegend = input$show_train) 428 | 429 | highchartProxy("chartbandwidth") |> 430 | hcpxy_update_series(id = "test", visible = input$show_train, showInLegend = input$show_train) 431 | 432 | }) 433 | 434 | } 435 | 436 | shinyApp(ui, server) --------------------------------------------------------------------------------