Instantly share code, notes, and snippets.

Embed
What would you like to do?
Shiny app for making polynomial lines from hand drawings, to appear in giorasimchoni.com
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