Shiny app for making polynomial lines from hand drawings, to appear in giorasimchoni.com
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
library(shiny) | |
library(glmnet) | |
res_list <- list() | |
get_poly_coef <- function(x, y, max_degree = 5) { | |
if (length(x) < 20) { | |
warning('x length less than 20') | |
} | |
mm <- model.matrix(~ poly(x, degree = max_degree, raw = TRUE))[, -1] | |
cvfit <- cv.glmnet(mm, y) | |
c(as.matrix(coef(cvfit, s = "lambda.min"))) | |
} | |
polynomize <- function(x, y, max_degree = 5) { | |
coef <- get_poly_coef(x, y, max_degree) | |
mm <- model.matrix(~ poly(x, degree = max_degree, raw = TRUE)) | |
list(xy = cbind(x, mm %*% coef), formula_ = form_latex(coef, x), coef_ = coef) | |
} | |
nice <- function(n) { | |
if (abs(n) %% 1 < 0.001) { | |
sprintf("%.4f", abs(n)) | |
} else if (abs(n) %% 1 < 0.01) { | |
sprintf("%.3f", abs(n)) | |
} else if (abs(n) %% 1 < 0.1) { | |
sprintf("%.2f", abs(n)) | |
} else { | |
sprintf("%.1f", abs(n)) | |
} | |
} | |
signit <- function(n) ifelse(n > 0, "+", "-") | |
pass <- function(n, eps = 0.000001) abs(n - 0) >= eps | |
format_x_range <- function(x) { | |
paste0("x\\in(", nice(min(x)), ",\\space", nice(max(x)), ")") | |
} | |
form_latex <- function(coef, x) { | |
formula_ <- "$$" | |
if (length(coef) > 0 && pass(coef[1])) { | |
formula_ <- paste0(formula_, nice(coef[1])) | |
} | |
if (length(coef) > 1 && pass(coef[2])) { | |
formula_ <- paste0(formula_, signit(coef[2]), nice(coef[2]), "x") | |
} | |
if (length(coef) > 2) { | |
deg <- 2 | |
for (co in coef[3:length(coef)]) { | |
if (pass(co)) { | |
formula_ <- paste0(formula_, signit(co), nice(co), "x^{", deg, "}") | |
deg <- deg + 1 | |
} | |
} | |
} | |
paste0(formula_, ";\\space ", format_x_range(x), "$$") | |
} | |
ui <- fluidPage( | |
withMathJax(), | |
h4("Click on plot to start drawing, click again to pause"), | |
fluidRow( | |
column(2, | |
numericInput("xmin", "xmin", min = -10, max = 0, step = 1, value = 0)), | |
column(2, | |
numericInput("xmax", "xmax", min = 1, max = 100, step = 1, value = 10)), | |
column(2, | |
numericInput("ymin", "ymin", min = -10, max = 0, step = 1, value = 0)), | |
column(2, | |
numericInput("ymax", "ymax", min = 1, max = 100, step = 1, value = 10)), | |
column(2, | |
numericInput("max_degree", "max degree", min = 1, max = 20, step = 1, value = 5)) | |
), | |
actionButton("reset", "reset"), | |
actionButton("jf", "just formulas"), | |
fluidRow( | |
column(6, | |
plotOutput("plot", width = "500px", height = "500px", | |
hover = hoverOpts(id = "hover", delay = 100, delayType = "throttle", clip = TRUE, nullOutside = TRUE), | |
click = "click")), | |
column(6, uiOutput("formulas")) | |
) | |
) | |
server <- function(input, output, session) { | |
vals <- reactiveValues(x = NULL, y = NULL, | |
xpred = NULL, ypred = NULL) | |
global_vals <- reactiveValues(x = NULL, y = NULL, | |
xpred = NULL, ypred = NULL) | |
formulas_text <- reactiveVal("") | |
draw <- reactiveVal(FALSE) | |
just_formulas <- reactiveVal(FALSE) | |
observeEvent(input$click, handlerExpr = { | |
temp <- draw(); draw(!temp) | |
if(!draw()) { | |
global_vals$x <- c(global_vals$x, NA) | |
global_vals$y <- c(global_vals$y, NA) | |
global_vals$xpred <- c(global_vals$xpred, NA) | |
global_vals$ypred <- c(global_vals$ypred, NA) | |
output$plot <- renderPlot({ | |
plot(x = global_vals$x, y = global_vals$y, xlim = c(input$xmin, input$xmax), | |
ylim = c(input$ymin, input$ymax), ylab = "y", xlab = "x", type = "l", lwd = 5) | |
lines(global_vals$xpred, global_vals$ypred, type = "l", col = 2, lwd = 5) | |
if (!draw()) { | |
if (!is.null(vals$x) && !is.null(vals$y)) { | |
res <- polynomize(vals$x, vals$y, input$max_degree) | |
res_list <<- c(res_list, list(res)) | |
global_vals$xpred <- c(global_vals$xpred, res$xy[, 1]) | |
global_vals$ypred <- c(global_vals$ypred, res$xy[, 2]) | |
formulas_text(paste(formulas_text(), res$formula_, sep = " ")) | |
output$formulas <- renderUI({withMathJax(HTML(formulas_text()))}) | |
vals$x <- NULL | |
vals$y <- NULL | |
} | |
} | |
}) | |
}}) | |
observeEvent(input$reset, handlerExpr = { | |
vals$x <- NULL; vals$y <- NULL | |
global_vals$x <- NULL; global_vals$y <- NULL | |
global_vals$x_backup <- NULL; global_vals$y_backup <- NULL | |
global_vals$xpred <- NULL; global_vals$ypred <- NULL | |
formulas_text("") | |
res_list <<- list() | |
}) | |
observeEvent(input$jf, handlerExpr = { | |
if (!just_formulas()) { | |
vals$x <- NULL; vals$y <- NULL | |
global_vals$x_backup <- global_vals$x; global_vals$y_backup <- global_vals$y | |
global_vals$x <- NULL; global_vals$y <- NULL | |
just_formulas(TRUE) | |
updateActionButton(session, "jf", label = "show all") | |
} else { | |
global_vals$x <- global_vals$x_backup; global_vals$y <- global_vals$y_backup | |
just_formulas(FALSE) | |
updateActionButton(session, "jf", label = "just formulas") | |
} | |
}) | |
observeEvent(input$hover, { | |
if (draw()) { | |
vals$x <- c(vals$x, input$hover$x) | |
vals$y <- c(vals$y, input$hover$y) | |
global_vals$x <- c(global_vals$x, input$hover$x) | |
global_vals$y <- c(global_vals$y, input$hover$y) | |
}}) | |
output$plot <- renderPlot({ | |
plot(x = global_vals$x, y = global_vals$y, xlim = c(input$xmin, input$xmax), | |
ylim = c(input$ymin, input$ymax), ylab = "y", xlab = "x", type = "l", lwd = 5) | |
}) | |
} | |
shinyApp(ui, server) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment