From 994c4f48f10e635bd7be97790004cd69ffdf859c Mon Sep 17 00:00:00 2001 From: Eduardo Junior <edujrrib@gmail.com> Date: Mon, 30 Nov 2015 12:46:23 -0200 Subject: [PATCH] =?UTF-8?q?Adiciona=20app=20dos=20pontos=20aleat=C3=B3rios?= =?UTF-8?q?=20elaborado=20na=20feira=20de=20cursos=202015?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- shiny/pontos/server.R | 161 ++++++++++++++++++++++++++++++++++++++++++ shiny/pontos/ui.R | 59 ++++++++++++++++ 2 files changed, 220 insertions(+) create mode 100644 shiny/pontos/server.R create mode 100644 shiny/pontos/ui.R diff --git a/shiny/pontos/server.R b/shiny/pontos/server.R new file mode 100644 index 0000000..97ada01 --- /dev/null +++ b/shiny/pontos/server.R @@ -0,0 +1,161 @@ +##------------------------------------------- +## server.R + +library(shiny) +## Carrega template das aplicações elaboradas pelo projeto iguiR2 +source("../template.R") +library(sp) +library(geoR) + +## Armazena o poligono do estado do Paraná +parana <- SpatialPolygons(list(Polygons(list(Polygon( + geoR::parana$borders)), "x"))) + +shinyServer( + function(input, output) { + ## Cabeçalho IGUIR2 + output$header <- renderPrint({ + template("TEMA") + }) + + ## Valores reativos que armazenam a posição dos pontos + ## realizados pelo usuário + val <- reactiveValues(x = NULL, y = NULL, z = FALSE, + option = "") + + ## Salva a posição dos pontos + observe({ + if (is.null(input$plot_click)){ + return() + } + isolate({ + val$x <- c(val$x, input$plot_click$x) + val$y <- c(val$y, input$plot_click$y) + }) + }) + + ## Exibe o número de pontos no quadro + output$npontos <- renderText({ + length(val$x) + }) + + ## Limpa os objetos reativos estimulado pelo `input$clear` + observe({ + if (input$clear > 0){ + val$x <- NULL + val$y <- NULL + val$z <- FALSE + val$option <- "" + } + }) + + ## Habilita exibição se houver mais de 19 pontos e se clicado em + ## `input$result` + observe({ + if (input$result > 0 & length(val$x) > 19){ + val$z <- TRUE + } + }) + + ## Armazena as opções escolhidas na seção de exemplos + observe({ + if(length(input$example) != 0){ + if(input$example == "Aleatório"){ + val$option <- "aleatorio" + } + if(input$example == "Regular alinhado"){ + val$option <- "regular.a" + } + if(input$example == "Regular desalinhado"){ + val$option <- "regular.d" + } + if(input$example == "Clusterizado"){ + val$option <- "cluster" + } + } + }) + + ## Realiza o teste via simulação + simula <- eventReactive( + input$result, { + if(length(val$x) > 19){ + n <- length(val$x) + + r <- replicate(100, { + M <- cbind(x = runif(n), y = runif(n)) + D <- c(dist(M)) + D + }) + return(list(n = n, r = r)) + } + }) + + ## Exibibe as opções de exemplo, após mais de 19 cliques + output$examples <- renderUI({ + if(val$z & length(val$x) > 19){ + radioButtons(inputId = "example", + label = "Disposição de pontos", + choices = c("Aleatório", + "Regular alinhado", + "Regular desalinhado", + "Clusterizado"), + selected = "", inline = FALSE) + } + }) + + ## Gráficos: i) do teste de hipóteses ii) dos exemplos com o + ## mapa do Paraná + output$plot1 <- renderPlot({ + if(val$z & length(val$x) > 19){ + if(val$option == ""){ + with(simula(), { + par(mar = c(0, 0, 0, 0), family = "Palatino") + plot(x = NULL, y = NULL, + xlim = range(r), ylim = c(0, 1), + axes = F, frame = T, xlab = "", ylab = "") + box(lwd = 2) + apply(r, 2, function(x) lines(ecdf(x), pch = NA)) + + dw.ac <- c(dist(cbind(val$x, val$y))) + lines(ecdf(dw.ac), col = 2, lwd = 2, pch = NA) + }) + } + if(val$option == "aleatorio"){ + par(mar = c(0, 0, 0, 0), family = "Palatino") + plot(parana, lwd = 3) + points(spsample(parana, n = 50, "random"), + pch = 19) + } + if(val$option == "regular.a"){ + par(mar = c(0, 0, 0, 0), family = "Palatino") + plot(parana, lwd = 3) + points(spsample(parana, n = 50, "regular"), + pch = 19) + + } + if(val$option == "regular.d"){ + par(mar = c(0, 0, 0, 0), family = "Palatino") + plot(parana, lwd = 3) + points(spsample(parana, n = 50, "nonaligned"), + pch = 19) + } + if(val$option == "cluster"){ + par(mar = c(0, 0, 0, 0), family = "Palatino") + plot(parana, lwd = 3) + points(spsample(parana, n = 50, "clustered", + nclusters = 10), pch = 19) + } + } else { + par(mar = c(0, 0, 0, 0)) + plot(x = c(0,1), y = c(0, 1), type = "n", + xlim = c(0, 1), ylim = c(0, 1), + xlab = "", ylab = "", main = "", + axes = FALSE, frame = TRUE) + box(lwd = 2) + + points(x = val$x, y = val$y, pch = 19) + } + }) + } +) + diff --git a/shiny/pontos/ui.R b/shiny/pontos/ui.R new file mode 100644 index 0000000..a224488 --- /dev/null +++ b/shiny/pontos/ui.R @@ -0,0 +1,59 @@ +##------------------------------------------- +## ui.R + +library(shiny) + +text <- "<div style=\"text-align:justify; +padding-left: 20px; padding-right: 20px\"> +<p> Este aplicativo exemplifica de forma simples um ramo da Estatística +em que a localização espacial das observações é de suma importância, a +Estatística Espacial. +</p> +<p> +O jogo consiste no objetivo de preencher o espaço ao lado com 20 pontos +de forma aletória. +</p></div> +" + +shinyUI( + fluidPage( + ## Cabeçalho IGUIR2 + htmlOutput("header"), + + titlePanel("Pontos aleatórios"), + + sidebarLayout( + sidebarPanel( + ## Texto de apoio + HTML(text), + + hr(), + + HTML('<FONT size=-1.5>Número de pontos:</FONT>'), + verbatimTextOutput("npontos"), + + ## Botões para executar o teste e recomeçar o jogo + actionButton( + inputId="result", + label="Ver Resultado", + class="btn btn-info"), + actionButton( + inputId="clear", + label="Recomeçar", + class="btn btn-warning"), + + hr(), + + ## Seção de exemplos + uiOutput("examples") + + ), + + mainPanel( + plotOutput("plot1", + click = "plot_click") + ) + ) + ) +) + -- GitLab