Created
December 24, 2015 15:04
-
-
Save sasanquaneuf/a5ce475e9e665e7e53ad to your computer and use it in GitHub Desktop.
Qlik SenseとShinyでコード進行を丁寧に描くと決めていたよ（Level 2） ref: http://qiita.com/sasanquaneuf/items/06d90cebe8b9ca775aea
This file contains hidden or 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(stringr) | |
| library(arules) | |
| library(DiagrammeR) | |
| df.test <- data.frame(a=1,b=2) | |
| shinyServer(function(input, output, session) { | |
| output$hideScript <- renderText({ | |
| query <- parseQueryString(session$clientData$url_search) | |
| if("key" %in% names(query)){ | |
| "<script>$('#keydiv').css('display','none');</script>" | |
| } else { | |
| "<script>$('#tablediv').css('display','none');$('#keydiv').css('display','block');</script>" | |
| } | |
| }) | |
| #output$tabletest <- renderDataTable(getRule()) | |
| output$mermaidtest <- renderDiagrammeR(mermaid(getDiagramExpr())) | |
| getRule <- function(support, confidence){ | |
| tryCatch({ | |
| setTimeLimit(5,5) | |
| df <- data.frame(before=df.test[[2]], after=df.test[[3]]) | |
| colnames(df)<-c("before","after") | |
| #print(df) | |
| d <- apriori(as(df,"transactions"), parameter=list(support=support, confidence=confidence)) | |
| setTimeLimit(Inf,Inf) | |
| },error=function(e){ | |
| setTimeLimit(Inf,Inf) | |
| stop(e) | |
| }) | |
| e <- as(d,"data.frame") | |
| e$LHS <- str_replace_all(e$rules,"=>.+","") | |
| e$RHS <- str_replace_all(e$rules,".+=>","") | |
| e | |
| } | |
| getDiagramExpr <- function(){ | |
| if(redirectFlg == T){ | |
| redirectFlg <<- F | |
| } else { | |
| t_support <<- input$support | |
| t_confidence <<- input$confidence | |
| } | |
| tryCatch({ | |
| updateNumericInput(session, "support", value = t_support) | |
| updateNumericInput(session, "confidence", value = t_confidence) | |
| }, error=function(e){ | |
| t_support <<- input$support | |
| t_confidence <<- input$confidence | |
| }) | |
| print(paste(input$support, input$confidence)) | |
| e <- getRule(t_support, t_confidence) | |
| nodes <- e[!is.na(str_match(e$LHS, "before")),] | |
| nodes$LHS <- nodes$LHS %>% str_replace_all("\\{before=","") %>% str_replace_all("\\}","") | |
| nodes$RHS <- nodes$RHS %>% str_replace_all("\\{after=","") %>% str_replace_all("\\}","") | |
| nodes$mermaid <- paste0(nodes$LHS, "-->|", (floor(nodes$confidence*1000)/10), "%|", nodes$RHS) | |
| nodes$mermaid <- str_replace_all(nodes$mermaid, "♭", "b") | |
| str <- paste("graph TD",Reduce(function(...){paste(...,sep="\n")},nodes$mermaid),sep="\n") | |
| str | |
| } | |
| api_url <- session$registerDataObj( | |
| name = 'api', # an arbitrary but unique name for the data object | |
| data = list(), # you can bind some data here, which is the data argument for the | |
| # filter function below. | |
| filter = function(data, req) { | |
| # print(ls(req)) # you can inspect what variables are encapsulated in this req | |
| # environment | |
| if (req$REQUEST_METHOD == "GET") { | |
| # handle GET requests | |
| query <- parseQueryString(req$QUERY_STRING) | |
| } | |
| if (req$REQUEST_METHOD == "POST") { | |
| # handle POST requests here | |
| reqInput <- req$rook.input | |
| # data must be one line and must be the form of http://www.yoheim.net/blog.php?q=20120611 | |
| strs <- paste0("?key=T") | |
| datastr <- reqInput$read_lines(1) | |
| str_split(datastr, "\\&") | |
| data <- parseQueryString(datastr) | |
| for(i in 1:length(data)){ | |
| data[[i]] <- str_split(iconv(data[[i]],"utf-8","cp932"),",") | |
| } | |
| df.test <<- data | |
| buf <- paste0( | |
| '<HEAD><META HTTP-EQUIV="Refresh" CONTENT="0; URL=http://127.0.0.1:7458/',strs, | |
| '" /></HEAD>') | |
| redirectFlg <<- T | |
| shiny:::httpResponse( | |
| status=200, content_type='text/html', content=buf | |
| ) | |
| } | |
| } | |
| ) | |
| # because the API entry is UNIQUE, we need to send it to the client | |
| # we can create a custom pipeline to convey this message | |
| session$sendCustomMessage("api_url", list(url=api_url)) | |
| }) |
This file contains hidden or 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(DiagrammeR) | |
| shinyUI(fluidPage( | |
| singleton(tags$head(HTML( | |
| ' | |
| <script type="text/javascript"> | |
| $(document).ready(function() { | |
| // creates a handler for our special message type | |
| Shiny.addCustomMessageHandler("api_url", function(message) { | |
| // set up the the submit URL of the form | |
| var shiny_test = document.getElementById("shiny_test") | |
| shiny_test.innerHTML = "http://127.0.0.1:7458/" + message.url; | |
| }); | |
| }) | |
| </script> | |
| ' | |
| ))), | |
| uiOutput("hideScript"), | |
| div(id="keydiv",style="display:none;", | |
| HTML("<span id='shiny_test'></span>") | |
| ), | |
| div(id="tablediv", | |
| numericInput("support", "support", 0.90), | |
| numericInput("confidence", "confidence", 0.50), | |
| DiagrammeROutput("mermaidtest") | |
| #,dataTableOutput("tabletest") | |
| ) | |
| )) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment