On my local computer, I use shiny to design a web page to show the analysis result. The data is extracted from the company's SQL database using RODBC to link the database to R. The code is like this:
library(shiny)
library(shinydashboard)
library(DT)
library(RODBC)
library(stringr)
library(dplyr)
DNS <- '***'
uid <- '***'
pwd <- '***'
convertMenuItem <- function(mi,tabName) {
mi$children[[1]]$attribs['data-toggle']="tab"
mi$children[[1]]$attribs['data-value'] = tabName
mi
}
sidebar <- dashboardSidebar(
sidebarMenu(
convertMenuItem(menuItem("Query1",tabName="Query1",icon=icon("table"),
dateRangeInput('Date1','Date Range',start = Sys.Date()-1, end = Sys.Date()-1,
separator=" - ",format="dd/mm/yy"),
textInput('Office1','Office ID','1980'),
submitButton("Submit")), tabName = "Query1"),
convertMenuItem(menuItem("Query2",tabName="Query2",icon=icon("table"),
dateRangeInput('Date2','Date Range',start = Sys.Date()-1, end = Sys.Date()-1,
separator=" - ",format="dd/mm/yy"),
textInput('Office2','Office ID','1980'),
submitButton("Submit")), tabName = "Query2"),
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName="Query1",
helpText('********************************'),
fluidRow(
column(12,DT::dataTableOutput('table1'))
)
),
tabItem(tabName = "Query2",h2("Widgets tab content"))
)
)
dashboardheader <- dashboardHeader(
title = 'LOSS PREVENTION'
)
ui <- dashboardPage(
skin='purple',
dashboardheader,
sidebar,
body
)
server <- function(input, output) {
output$table1 <- DT::renderDataTable({
ch<-odbcConnect(DNS,uid=uid,pwd=pwd)
a <- sqlQuery(ch,paste(' ***'))
odbcClose(ch)
DT::datatable(a,options = list(scrollX=T))
})
}
shinyApp(ui, server)
Then, I have my account on shinyapps.io. And use rsconnect to deploy this programm. And the deployment is successful.
But when I use https://myAccount.shinyapps.io/myshiny/ to access my code. I have the following error:
2018-05-10T00:57:38.473259+00:00 shinyapps[340325]: Warning in RODBC::odbcDriverConnect("DSN=****;UID=****;PWD=****") :
2018-05-10T00:57:38.473262+00:00 shinyapps[340325]: [RODBC] ERROR: state IM002, code 0, message [unixODBC][Driver Manager]Data source name not found, and no default driver specified
But, if there is no RODBC and SQL database involved in my code, the code works fine.
So, the problem is because shinyapps.io cannot access my company's SQL database. How can I deal with it?
The app works on your computer because the Data Source Name (DSN) has been configured there. It is not configured on shinyapps.io. According to this help article you can use for example
odbcDriverConnect('Driver=FreeTDS;TDS_Version=7.0;Server=<server>;Port=<port>;Database=<db>;Uid=<uid>;Pwd=<pw>;Encrypt=yes;TrustServerCertificate=no;Connection Timeout=30;')
A more complete treatment can be found in the documentation.
Related
I have written a simple example of what I am doing. I have 3000 numbers that I want to show in a selectInput. The numbers have to be in a reactive function, since in my original work, the data is from a file.
My problem is that when I run the app it only appears 1000 numbers, not the entire data (3000 numbers).
I have seen this post Updating selection of server-side selectize input with >1000 choices fails but I don't know how can I do it using uiOutput and renderUI.
Can anyone help me?
Thanks very much in advance
The code:
library(shiny)
ui <- fluidPage(
titlePanel("Numbers"),
sidebarLayout(
sidebarPanel(
uiOutput('selectUI')
),
mainPanel(
)
)
)
server <- function(input, output) {
num <- reactive({
data = c(1:3000)
return(data)
})
output$selectUI <- renderUI({
selectInput(inputId = 'options', "Select one", choices = num())
})
}
# Run the application
shinyApp(ui = ui, server = server)
Use selectizeInput instead of selectInput with the argument options = list(maxOptions = 3000).
Thanks to Stéphane Laurent's answer, the example will be solved like this:
library(shiny)
ui <- fluidPage(
titlePanel("Numbers"),
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "options", label = "Select one", choices=character(0)),
),
mainPanel(
)
)
)
server <- function(input, output, session) {
num <- reactive({
data = c(1:3000)
return(data)
})
observe({
updateSelectizeInput(
session = session,
inputId = "options",
label = "Select one",
choices= num(), options=list(maxOptions = length(num())),
server = TRUE)
})
}
# Run the application
shinyApp(ui = ui, server = server)
This code will work if you have more than 3000 entries. It will show you ALL the choices that you have. However, if you have a long list of choices (e.g. 60000) it will decrease the speed of your app.
The following shiny app works the first time you run it, but then errors if you change the species input because the table name already exists in memory. I was wondering how to set overwrite == TRUE given the code below?
library(shiny)
library(tidyverse)
library(dbplyr)
ui <- fluidPage(
selectInput("species", "Species", choices = unique(iris$Species),
selected = "setosa"),
tableOutput("SQL_table"),
actionButton("code", "View SQL"),
)
server <- function(input, output) {
# render table
output$SQL_table <- renderTable(
head(iris %>% filter(Species == input[["species"]]))
)
# generate query
SQLquery <- reactive({
sql_render(
show_query(
tbl_memdb(iris) %>%
filter(Species == local(input$species))
)
)
})
# see query
observeEvent( input$code, {
showModal(
modalDialog(
SQLquery()
)
)
})
}
shinyApp(ui = ui, server = server)
since memdb_frame is just a function call of copy_to we can use it directly to set overwrite = TRUE
copy_to(src_memdb(), iris, name = 'iris', overwrite=TRUE)
I'm trying to fetch data which includes some German word with umlaut characters. following the bellow structure everything is fine in windows machine :
Sys.setlocale('LC_ALL','C')
library(RMySQL)
conn <- dbConnect(MySQL(), user = "user", dbname = "database",
host = "host", password = "pass")
sql.query <- paste0("some query")
df <- dbSendQuery(conn, sql.query)
names <- fetch(df, -1)
dbDisconnect(conn)
As an example I have :
names[1230]
[1] "Strübbel"
What should I change in order to get the same result in Linux Ubuntu ?
the query will run without problem, but the result is :
names[1230]
[1] "Str\374bbel"
I have checked This solution, but when I put the 'set character set "utf8"' inside of query I'm getting the following error :
df <- dbSendQuery(conn, sql.query, 'set character set "utf8"')
names <- fetch(df, -1)
Error in .local(conn, statement, ...) :
unused argument ("set character set \"utf8\"")
I should mention the encoding for the result is unknown :
Encoding(names[1230])
[1] "unknown"
and doing the :
Encoding(names[1230]) <- "UTF-8"
names[1230]
[1] "Str<fc>bbel"
does not solve the problem !
Instead of :
Sys.setlocale('LC_ALL','C')
You have to use :
Sys.setlocale('LC_ALL','en_US.UTF-8')
and in the sql query :
library(RMySQL)
conn <- dbConnect(MySQL(), user = "user", dbname = "database",
host = "host", password = "pass")
sql.query <- paste0("some query")
dbSendQuery(conn,'set character set "utf8"')
df <- dbSendQuery(conn, sql.query)
names <- fetch(df, -1)
dbDisconnect(conn)
Not sure if this solution will help you but you could try such approach:
con <- dbConnect(MySQL(), user = "user", dbname = "database",
host = "host", password = "pass", encoding = "ISO-8859-1")
If this encoding doesn't work then try "brute force" with different variants
I am trying to create a shiny app. This app uses a .csv file uploaded by the user. I do not really understand how fileInput() works in the sense of storing the data frame.
I am using this code to upload the file:
data_OBS = reactive({
inFile <- input$file1
if (is.null(inFile))
return(NULL)
read.csv(inFile$datapath, header=T, sep=",")
})
If I understood well, the data frame should be accesible in data_OBS(). If the .csv file I want to upload has a column named for example "CL" in normal R enviorement I should be able to access using data_OBS$CL. However, in shiny data_OBS() is a function. I have tried data_OBS$CL, data_OBS()$CL, data_OBS(CL) but none of them worked. How can access to the data just uploaded?
Thanks in advance,
Best,
You can access it with data_OBS()$CL, but only inside reactive context such as observe, observeEvent, eventReactive.
Here is a minimal example using observeEvent:
ui <- fluidPage(
fileInput("file1", "Choose CSV File"),
textOutput("text"),
actionButton("print", "Print to text output")
)
server <- function(input, output, session){
data_OBS = reactive({
inFile <- input$file1
if (is.null(inFile))
return(NULL)
read.csv(inFile$datapath, header=T, sep=",")
})
observeEvent(input$print, {
req(input$file1) # Doesn't do anything until a file is uploaded
output$text <- renderText(data_OBS()$CL)
})
}
shinyApp(ui, server)
First to check it did not return null. Also, you may force return(read.csv(...))
data_OBS()$CL should work.
I started playing with the idea of testing a webpage load time using R. I have devised a tiny R code to do so:
page.load.time <- function(theURL, N = 10, wait_time = 0.05)
{
require(RCurl)
require(XML)
TIME <- numeric(N)
for(i in seq_len(N))
{
Sys.sleep(wait_time)
TIME[i] <- system.time(webpage <- getURL(theURL, header=FALSE,
verbose=TRUE) )[3]
}
return(TIME)
}
And would welcome your help in several ways:
Is it possible to do the same, but to also know which parts of the page took what parts to load? (something like Yahoo's YSlow)
I sometime run into the following error -
Error in curlPerform(curl = curl,
.opts = opts, .encoding = .encoding) :
Failure when receiving data from the
peer Timing stopped at: 0.03 0 43.72
Any suggestions on what is causing this and how to catch such errors and discard them?
Can you think of ways to improve the above function?
Update: I redid the function. It is now painfully slow...
one.page.load.time <- function(theURL, HTML = T, JavaScript = T, Images = T, CSS = T)
{
require(RCurl)
require(XML)
TIME <- NULL
if(HTML) TIME["HTML"] <- system.time(doc <- htmlParse(theURL))[3]
if(JavaScript) {
theJS <- xpathSApply(doc, "//script/#src") # find all JavaScript files
TIME["JavaScript"] <- system.time(getBinaryURL(theJS))[3]
} else ( TIME["JavaScript"] <- NA)
if(Images) {
theIMG <- xpathSApply(doc, "//img/#src") # find all image files
TIME["Images"] <- system.time(getBinaryURL(theIMG))[3]
} else ( TIME["Images"] <- NA)
if(CSS) {
theCSS <- xpathSApply(doc, "//link/#href") # find all "link" types
ss_CSS <- str_detect(tolower(theCSS), ".css") # find the CSS in them
theCSS <- theCSS[ss_CSS]
TIME["CSS"] <- system.time(getBinaryURL(theCSS))[3]
} else ( TIME["CSS"] <- NA)
return(TIME)
}
page.load.time <- function(theURL, N = 3, wait_time = 0.05,...)
{
require(RCurl)
require(XML)
TIME <- vector(length = N, "list")
for(i in seq_len(N))
{
Sys.sleep(wait_time)
TIME[[i]] <- one.page.load.time(theURL,...)
}
require(plyr)
TIME <- data.frame(URL = theURL, ldply(TIME, function(x) {x}))
return(TIME)
}
a <- page.load.time("http://www.r-bloggers.com/", 2)
a
your getURL call will only do one request and get the source HTML for the web page. It won't get the CSS or Javascript or other elements. If this is what you mean by 'parts' of the web page then you'll have to scrape the source HTML for those parts (in SCRIPT tags, or css references etc) and getURL them separately with timing.
Perhaps Spidermonkey from Omegahat could work.
http://www.omegahat.org/SpiderMonkey/