sasanquaneuf/server.R

## server.R
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))
})

## ui.R
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")
  )
))
	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))
	})
	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")
	)
	))