I am trying to build a shiny app where extract_text and extract_table functions from R tabulizer package are used. But the problem is in an instance the results from the first file I upload remains, i.e. if I upload a pdf file the desired results appear, but even if I upload a new file the results don't change unless I stop and start a new instance. Here is my server.R code-
shinyServer(function(input,output,session) {
fund<-reactive({
inFile <- input$file1
if (is.null(inFile))
{return(NULL)} else {
rr<-extract_text(inFile$datapath, pages =2)
e1<-extract_tables(inFile$datapath, pages =1)
e2<-extract_tables(inFile$datapath, pages =2)
rr<-gsub("\r\n", " ", rr)
ss<-unlist(strsplit(rr, "Total & WAR:"))
gr<-grep("Reverse Repo With Bank", ss)
if (length(gr)>=1) {
sk<-gsub("(?<=[\\s])\\s*|^\\s+|\\s+$", "", ss[gr], perl=T)
sn<-unlist(strsplit(sk, " ", fixed=T))
grp<-grep("Limited", sn)
dm<-matrix(nrow=length(grp), ncol=4)
party<-c()
for (i in 1:length(grp)){
dm[i,]<-sn[(grp[i]+1):(grp[i]+4)]
party[i]<-paste(sn[(grp[i]-2):(grp[i])],sep="", collapse=" ")
}
dm<-as.data.frame(dm)
names(dm)<-c("Amount", "Rate", "DealDate", "MaturityDate" )
dm$PartyName<-party
dm$Tenure<-rep("", times=nrow(dm))
dm<-dm[,c(5:6,1:4)]
dn<-data.frame(PartyName="Product Name : Reverse Repo with Bank", Tenure="", Amount="", Rate="", DealDate="", MaturityDate="")
dnn<-data.frame(PartyName="Total & WAR:", Tenure="", Amount="", Rate="", DealDate="", MaturityDate="")
dm<-rbind(dn,dm,dnn)
}
if (length(e1)>1) {
l1<-dim(e1[[1]])[1]
l2<-dim(e1[[2]])[1]
m<-c(l1,l2)
e<-e1[[which(m==max(m))]]
} else {e=e1[[1]]}
gop<-grep("Party Name", e[,1], fixed=T)
e<-e[-(1:(gop-1)),]
e[,3]<-gsub("(?<=[\\s])\\s*|^\\s+|\\s+$", "", e[,3], perl=T)
if (ncol(e)==4){
ss<-strsplit(e[,3], " ")
s1<-sapply(ss, function(x) x[1])
s2<-sapply(ss, function(x) x[2])
sss<-strsplit(e[,4], " ")
s1s<-sapply(sss, function(x) x[1])
s2s<-sapply(sss, function(x) x[2])
e<-cbind(e[,1:2],s1,s2,s1s,s2s)
} else if (ncol(e)==5) {
sss<-strsplit(e[,5], " ")
s1s<-sapply(sss, function(x) x[1])
s2s<-sapply(sss, function(x) x[2])
e<-cbind(e[,1:4],s1s,s2s)
}
d<-rbind(e[-1,],e2[[1]][-1,])
d<-as.data.frame(d)
colnames(d)<-c("PartyName", "Tenure", "Amount", "Rate", "DealDate", "MaturityDate")
if (length(gr)>=1){
d<-rbind(d,dm)
}
row.names(d)<-1:nrow(d)
d$Rate<-as.numeric(as.character(d$Rate))
w<-which(d$Rate>7)
d<-d[-w,]
d$IncomeType<-rep(NA, nrow(d))
d$Rate[is.na(d$Rate)]<-0
levels<-c(-1,1,5,7)
labels<-c("Invalid","Low Income", "Medium Income")
d$IncomeType<-cut(d$Rate, levels, labels)
d$Period<-as.Date(d$MaturityDate, format="%d/%m/%Y")-Sys.Date()
d$Period[is.na(d$Period)]<-1
levels1<-c(-50,-1,1,15,30,5000)
labels1<-c("Already Matured", "Within 1 Day", "Within 2 to 15 Days", "Within 16 to 30 Days", "More than 1 Month")
d$MaturityType<-cut(as.numeric(d$Period), levels1, labels1)
m<-grep("Product Name : Commercial Paper", d[,1], fixed=T)
d<-d[-m,]
g1<-grep("Product Name",d[,1], fixed=T)
name<-d[g1,1]
name<-as.character(name)
name<-sapply(strsplit(name,": "), "[", 2)
g2<-grep("Total & WAR",d[,1], fixed=T)
w<-which(d[,1]=="Product Name : Call Borrowing with Bank")
if (length(w)>=1){
d<-d[-(g1[which(g1==w)]:g2[which(g1==w)]),]
name<-name[-which(g1==w)]
g1<-grep("Product Name",d[,1], fixed=T)
g2<-grep("Total & WAR",d[,1], fixed=T)
}
Product<-c()
for (i in 1: length(g1)) {
Product[(g1[i]):(g2[i])]<-name[i]
}
d$Product<-Product
d<-d[!(is.na(d$DealDate)|d$DealDate==""),]
d$Amount<-as.numeric(gsub(",", "", d$Amount))
Remaining<-as.Date(d$MaturityDate, format="%d/%m/%Y")-Sys.Date()
d$Remaining<-ifelse(is.na(Remaining)!=TRUE, Remaining, "ON CALL")
d<-d[order(d$IncomeType,d$Product),]
d<-d[,c(1,10,3,4,7,5,6,11)]
d$DealDate<-as.character(d$DealDate)
d$MaturityDate<-as.character(d$MaturityDate)
d$Period<-as.Date(d$MaturityDate, format="%d/%m/%Y")-Sys.Date()
d$Period[is.na(d$Period)]<-1
levels1<-c(-5000,0,1,15,30,5000)
labels1<-c("Already Matured", "Matures Next Day", "In Between 2 to 15 Days", "In Between 16 to 30 Days", "More than 1 Month")
d$MaturityType<-cut(as.numeric(d$Period), levels1, labels1)
d1<-d[,1:8]
d1<-d1[order(d$IncomeType,d$Product),]
rate<-sum(as.numeric(d1$Amount)*as.numeric(d1$Rate)/sum(as.numeric(d1$Amount)))
d1<-as.data.frame(apply(d1, 2, function(x) gsub("^\\s+|\\s+$", "", x)), stringsAsFactors = F)
d1$MaturityDate[is.na(d1$MaturityDate)]<-""
d1[(nrow(d1)+1),]<-c("Total","",sum(as.numeric(d1$Amount)),rate, rep("", times=4))
row.names(d1)<-1:nrow(d1)
tt<-daply(d,.(IncomeType, Product), summarize, sum(Amount),.drop_i = F)
tt<-tt[-1,]
rrr<-rowSums(apply(tt,2, as.numeric))
tt<-cbind(tt,Total=rrr)
cc<-colSums(apply(tt, 2, as.numeric))
tt<-rbind(tt,Total=cc)
tt1<-daply(d,.(IncomeType, MaturityType), summarize, sum(Amount),.drop_i = F)
tt1<-tt1[-1,]
rrr<-rowSums(apply(tt1,2, as.numeric))
tt1<-cbind(tt1,Total=rrr)
cc<-colSums(apply(tt1, 2, as.numeric))
tt1<-rbind(tt1,Total=cc)
ECRR<-as.numeric(gsub(",","",e2[[2]][2,2]))-as.numeric(gsub(",","",e2[[2]][1,2]))
if(ECRR<0){
ECRR<-0
} else {ECRR=ECRR}
ECRR<-data.frame(ECRR)
names(ECRR)<-"OMG"
list(ECRR=ECRR,tt=tt,tt1=tt1,d1=d1)}
})
output$fileUploaded <- reactive({
return(!is.null(fund()))
})
outputOptions(output, 'fileUploaded', suspendWhenHidden=FALSE)
name<-c("ECRR","tt","tt1","details")
save.xlsx <- function (file, ...)
{
require(xlsx, quietly = TRUE)
objects <- list(...)
fargs <- as.list(match.call(expand.dots = TRUE))
objnames <- as.character(fargs)[-c(1, 2)]
nobjects <- length(objects)
for (i in 1:nobjects) {
if (i == 1)
write.xlsx(objects[[i]], file, sheetName = name[i])
else write.xlsx(objects[[i]], file, sheetName = name[i],
append = TRUE)
}
print(paste("Workbook", file, "has", nobjects, "worksheets."))
}
output$F<-renderTable({fund()$ECRR})
output$G<-renderTable({fund()$tt},rownames=T)
output$H<-renderTable({fund()$tt1},rownames=T)
output$I<-renderTable({fund()$d1},rownames=T)
output$downloadData <- downloadHandler(
filename = "ALM.xlsx",
content = function(file) {
save.xlsx(file,fund()$ECRR,fund()$tt,fund()$tt1,fund()$d1)
}
)
})
And ui.R
library(shiny)
shinyUI(pageWithSidebar (
headerPanel( "Fund"),
sidebarPanel(width=3,
fileInput('file1', 'Choose a file to upload',
accept = c(
'.pdf'
)),
helpText("(Only .pdf files can be uploaded"),
conditionalPanel("output.fileUploaded",
downloadButton('downloadData'))
),
mainPanel (
tabsetPanel(
tabPanel("ECRR", tableOutput("F")),
tabPanel("Product wise Distribution", tableOutput("G")),
tabPanel("Maturity wise Distribution", tableOutput("H")),
tabPanel("Details", tableOutput("I"))
))
)
)
If anybody wants to test the files I am trying to upload here are 2 of them
[File1][1]
[File2][2]
Sorry for the very messy code and thanks in advance.
Related
This script outputs excel spreadsheets of different region. However, since I included a column "Later", changed the corresponding template to also include the column "Later" and increased the number on this line "df <- subset(clist[,c(1:18, 20:29)" from 28 to 29 (given the increased column). The output on the column "group" has come back with its content, but with quotation mark and some instance with CHAR(10).
Is there anyway I can edit this script to have column "group" outcome its content without the quotation marks. Please help!! help! I have struggled with this since. See script below
NB changes made to the original script are as follows
inclusion of later in the sqlcode
changing the df <- subset(clist[,c(1:18, 20:28)" to df <- subset(clist[,c(1:18, 20:29)
Changing the second df <- subset(clist[,c(1:17, 19:28)] to df <- subset(clist[,c(1:18, 20:29)]
#####Constants#####
requiredpackages <- c("XLConnect", "RPostgreSQL", "svDialogs", "getPass")
reqpackages <- function(requiredpackages){
for( i in requiredpackages ){
if( ! require( i , character.only = TRUE ) ) {
install.packages( i , dependencies = TRUE )
library( i , character.only = TRUE )
}
}
}
# set the version to 1.0.5
packageurl <- "https://cran.r-project.org/src/contrib/Archive/XLConnect/XLConnect_1.0.5.tar.gz"
install.packages(packageurl, repos=NULL, type="source")
library(XLConnect)
library(RPostgreSQL)
library(svDialogs)
library(getPass)
source("N:/Ana/Code/Analysiss/Rational/R SQL working/postgresql-avd.R")
#####Retrieve data from analysis server#####
sqlcode <- paste("SELECT concat_ws(';',datacompletion,sortprovider) as datacompletion,ba,outstandingdata,provider,summary,
m,m_hos,m_sur,m_for,m_dob,ed,
bkhos,delhos,
pregnancy,b_d,
b,b_na,
group,groupsw,later,estimated,
screening,date,screening2,
booking,city,use,con,water
FROM common.etl_chasing
where ((date::text like '%",tperiod,"%' or date::text like '%",cperiod,"%')
and (anomalygroup like '%Down%' or group like '%Edwards%' or group like '%Patau%'))
or eddfyear like '%", fperiod,"%' or cleanyear like '%", cperiod, "%'", sep='')
con <- createConnection()
clist <- dbGetQuery(con, sqlcode)
dbDisconnect(con)
#####Create new folder on PID drive to output chasing lists to#####
dirname <- paste("P:/Data/Antenatal/Testing/", Sys.Date(),sep='')
dir.create(dirname)
#####Export CSV of all data#####
write.csv(clist,paste(dirname,"/masterlist.csv",sep=''))
#####Copy template for all individual providers#####
sortproviders <- unique(clist$sortprovider)
inpath <- "P:/Data/National/Antenatal/Template17b.xlsx"
for (i in seq_along(sortproviders)) {
outpath <- paste(dirname,"/",sortproviders\[i\]," AN LIST.xlsx", sep='')
file.copy(from = inpath, to = outpath)
}
#####Populate templates for individual providers#####
swpatterns <- c("68 - ", "70 - ", "72 - ", "73 - ", "84 - ", "93 - ", "94 - ", "95 - ", "96 - ", "99 - ")
#grepl(paste(swpatterns, collapse = "|"), sortproviders\[1\])
#otherpatterns \<- c("72 - ", "96 - ", "73 - ", "93 - ", "94 - ", "72 - ", "99 - ")
#swsortproviders \<- unique(grep(paste(swpatterns, collapse = "|"), sortproviders, value = TRUE))
#restsortprividers \<- unique(grep(paste(otherpatterns, collapse = "|"), sortproviders, value = TRUE))
for (i in seq_along(sortproviders)) {
outpath \<- paste(dirname,"/",sortproviders\[i\]," AN LIST.xlsx", sep='')
if (grepl(paste(swpatterns, collapse = "|"), sortproviders\[i\]) == FALSE) {
df <- subset(clist[,c(1:18, 20:29)], sortprovider == sortproviders[i])
dfformulacol <- as.vector(df$anomalygroup)
df <- cbind(df, df)
XLConnect::writeWorksheetToFile(outpath, df, sheet = "trust list", startRow = 4, header = FALSE, styleAction = XLC$"STYLE_ACTION.NONE")
wb <- loadWorkbook(filename = outpath, create = FALSE)
for (j in seq_along(dfformulacol)) {
setCellFormula(wb, "trust list", j+3, 18, dfformulacol[j])
}
for (k in seq_along(dfformulacol)) {
setCellFormula(wb, "trust list", k+3, 45, dfformulacol[k])
}
saveWorkbook(wb)
rm(wb)
} else {
df <- subset(clist[,c(1:18, 20:29)], sortprovider == sortproviders[i])
df <- cbind(df, df)
XLConnect::writeWorksheetToFile(outpath, df, sheet = "trust list", startRow = 4, header = FALSE, styleAction = XLC$"STYLE_ACTION.NONE")
wb <- loadWorkbook(filename = outpath, create = FALSE)
saveWorkbook(wb)
rm(wb)
}
rm(df)
xlcFreeMemory()
}
#####################################
I need to capture the user selection from a DTedit table to build other tables.
I have used the input$<table>_rows_selected from a fresh DT objects but do not succeed doing it from a DTedit object.
I suspect that I need to build some intermediate object to capture the selection but cannot figure it out.
I added few lines to the DTedit demo code below to illustrate my issue.
Thanks for your help
library(shiny)
library(RSQLite)
library(DTedit); # devtools::install_github('jbryer/DTedit')
# Code modified from: https://github.com/jbryer/DTedit/blob/master/inst/shiny_demo/app.R
##### Load books data.frame as a SQLite database
conn <- dbConnect(RSQLite::SQLite(), "books.sqlite")
if(!'books' %in% dbListTables(conn)) {
books <- read.csv('books.csv', stringsAsFactors = FALSE)
books$Authors <- strsplit(books$Authors, ';')
books$Authors <- lapply(books$Authors, trimws) # Strip white space
books$Authors <- unlist(lapply(books$Authors, paste0, collapse = ';'))
books$id <- 1:nrow(books)
books$Date <- paste0(books$Date, '-01-01')
dbWriteTable(conn, "books", books, overwrite = TRUE)
}
getBooks <- function() {
res <- dbSendQuery(conn, "SELECT * FROM books")
books <- dbFetch(res)
dbClearResult(res)
books$Authors <- strsplit(books$Authors, ';')
books$Date <- as.Date(books$Date)
books$Publisher <- as.factor(books$Publisher)
return(books)
}
##### Callback functions.
books.insert.callback <- function(data, row) {
query <- paste0("INSERT INTO books (id, Authors, Date, Title, Publisher) VALUES (",
"", max(getBooks()$id) + 1, ", ",
"'", paste0(data[row,]$Authors[[1]], collapse = ';'), "', ",
"'", as.character(data[row,]$Date), "', ",
"'", data[row,]$Title, "', ",
"'", as.character(data[row,]$Publisher), "' ",
")")
print(query) # For debugging
dbSendQuery(conn, query)
return(getBooks())
}
books.update.callback <- function(data, olddata, row) {
query <- paste0("UPDATE books SET ",
"Authors = '", paste0(data[row,]$Authors[[1]], collapse = ';'), "', ",
"Date = '", as.character(data[row,]$Date), "', ",
"Title = '", data[row,]$Title, "', ",
"Publisher = '", as.character(data[row,]$Publisher), "' ",
"WHERE id = ", data[row,]$id)
print(query) # For debugging
dbSendQuery(conn, query)
return(getBooks())
}
books.delete.callback <- function(data, row) {
query <- paste0('DELETE FROM books WHERE id = ', data[row,]$id)
dbSendQuery(conn, query)
return(getBooks())
}
##### Create the Shiny server
server <- function(input, output) {
books <- getBooks()
dtedit(input, output,
name = 'books',
thedata = books,
edit.cols = c('Title', 'Authors', 'Date', 'Publisher'),
edit.label.cols = c('Book Title', 'Authors', 'Publication Date', 'Publisher'),
input.types = c(Title='textAreaInput'),
input.choices = list(Authors = unique(unlist(books$Authors))),
view.cols = names(books)[c(5,1,3)],
callback.update = books.update.callback,
callback.insert = books.insert.callback,
callback.delete = books.delete.callback)
# removed the second example
# added for this post using 'input$books_rows_selected' to capture the required info
output$selectedrow <- renderPrint({
s <- input$books_rows_selected
cat(paste0("selected ID:", s))
if (length(s)) {
cat(getBooks()[s,1])
}
})
}
##### Create the shiny UI
ui <- fluidPage(
h3('Books'),
uiOutput('books'),
verbatimTextOutput('selectedrow') # added for this post
)
shinyApp(ui = ui, server = server)
Here is a working example using a my modified version (v2.2.3+) of jbryer's DTedit:
My modified version of DTedit returns reactiveValues, including $rows_selected (only one row can be selected, though!).
library(shiny)
library(RSQLite)
library(DTedit); # devtools::install_github('DavidPatShuiFong/DTedit')
# Code modified from: https://github.com/jbryer/DTedit/blob/master/inst/shiny_demo/app.R
##### Load books data.frame as a SQLite database
conn <- dbConnect(RSQLite::SQLite(), "books.sqlite")
if(!'books' %in% dbListTables(conn)) {
books <- read.csv('books.csv', stringsAsFactors = FALSE)
books$Authors <- strsplit(books$Authors, ';')
books$Authors <- lapply(books$Authors, trimws) # Strip white space
books$Authors <- unlist(lapply(books$Authors, paste0, collapse = ';'))
books$id <- 1:nrow(books)
books$Date <- paste0(books$Date, '-01-01')
dbWriteTable(conn, "books", books, overwrite = TRUE)
}
getBooks <- function() {
res <- dbSendQuery(conn, "SELECT * FROM books")
books <- dbFetch(res)
dbClearResult(res)
books$Authors <- strsplit(books$Authors, ';')
books$Date <- as.Date(books$Date)
books$Publisher <- as.factor(books$Publisher)
return(books)
}
##### Callback functions.
books.insert.callback <- function(data, row) {
query <- paste0("INSERT INTO books (id, Authors, Date, Title, Publisher) VALUES (",
"", max(getBooks()$id) + 1, ", ",
"'", paste0(data[row,]$Authors[[1]], collapse = ';'), "', ",
"'", as.character(data[row,]$Date), "', ",
"'", data[row,]$Title, "', ",
"'", as.character(data[row,]$Publisher), "' ",
")")
print(query) # For debugging
dbSendQuery(conn, query)
return(getBooks())
}
books.update.callback <- function(data, olddata, row) {
query <- paste0("UPDATE books SET ",
"Authors = '", paste0(data[row,]$Authors[[1]], collapse = ';'), "', ",
"Date = '", as.character(data[row,]$Date), "', ",
"Title = '", data[row,]$Title, "', ",
"Publisher = '", as.character(data[row,]$Publisher), "' ",
"WHERE id = ", data[row,]$id)
print(query) # For debugging
dbSendQuery(conn, query)
return(getBooks())
}
books.delete.callback <- function(data, row) {
query <- paste0('DELETE FROM books WHERE id = ', data[row,]$id)
dbSendQuery(conn, query)
return(getBooks())
}
##### Create the Shiny server
server <- function(input, output) {
books <- getBooks()
my_results <- dtedit(input, output,
name = 'books',
thedata = books,
edit.cols = c('Title', 'Authors', 'Date', 'Publisher'),
edit.label.cols = c('Book Title', 'Authors', 'Publication Date', 'Publisher'),
input.types = c(Title='textAreaInput'),
input.choices = list(Authors = unique(unlist(books$Authors))),
view.cols = names(books)[c(5,1,3)],
callback.update = books.update.callback,
callback.insert = books.insert.callback,
callback.delete = books.delete.callback)
output$selectedrow <- shiny::eventReactive(
my_results$rows_selected, ignoreInit = TRUE, {
paste0("selected ID: ", my_results$rows_selected)
})
}
##### Create the shiny UI
ui <- fluidPage(
h3('Books'),
uiOutput('books'),
verbatimTextOutput('selectedrow') # added for this post
)
shinyApp(ui = ui, server = server)
Anyone running this example will actually need the .csv/.sqlite file, which is available in both jbryer DTedit and in my modified version.
I am trying to build a shiny app where the sidebar is dynamic based on the tab that is selected. The sidebar is populated by a csv file. Right now it is just reading a CSV file named machines.csv. I would want that to be able to read for example austin.csv, dallas.cav based on the tab name. There will be 7 tabs total. Also I am having trouble with the plot area. I want the plot to render to the correct tab (which is always the selected tab).
The code I have is here. The app is at http://45.55.208.171:3838/
Only the first two machines have data right now. And the Dallas tab I can not get to work because it seems I can't use the same render plot ID. Not sure how to make that dynamic based on the tab as well.
library(shiny)
library(ggplot2)
library(scales)
library(grid)
library(RColorBrewer)
library(lubridate)
library(ggrepel)
library(plyr)
library(dplyr)
library(DT)
library(RCurl)
library(readr)
library(stringr)
Machine <-read.csv("machines.csv")
Sys.setenv(TZ="US/Central")
SDate <- Sys.Date()
ui <- fluidPage(
titlePanel("Printer Utilization"),
sidebarLayout(
sidebarPanel(width = 2,
radioButtons("typeInput", "Machine", t(Machine[1]) , width = 4),
dateInput("RepDate", "Date of Report",format = "mm-dd-yyyy",value = "08-03-2016"),
downloadButton("downloadplot", "Download")),
mainPanel(
tabsetPanel(id = "plants",
tabPanel("Austin",value = "Austin", plotOutput("plants",width = "120%",height = "600px")),
tabPanel("Dallas",value = "Dallas", plotOutput("Dallas",width = "120%",height = "600px")),
tabPanel("Table", div(DT::dataTableOutput("log"), style = "font-size:50%")))
)))
server <- function(input, output) {
output$plants <-renderPlot({
Sys.setenv(TZ="US/Central")
SDate <- Sys.Date()
SDate <-as.POSIXct(SDate,format="%Y%m%d")+18000
RepDate.1 <- reactive({ as.POSIXct(input$RepDate,format="%Y%m%d", tz="US/Central")}+18000)
typeInput.1 <- reactive({input$typeInput})
RDate <- RepDate.1()
Machine.1<-reactive({subset(Machine,MNames.i==typeInput.1())})
Serial = Machine.1()$Serial.i
IP = Machine.1()$IP.i
Type = Machine.1()$Type.i
if (Type=="b"){
if (SDate==RepDate.1())
{
extension <- ".ACL"
logdata <- (read.csv(paste(Serial, as.character(RDate,format="%Y%m%d"), extension, sep = "") , sep = ';'))
RDate <- RDate-86400
extension <- ".CSV"
logdata <- (rbind(read.csv(paste(Serial, as.character(RDate,format="%Y%m%d"), extension, sep = "") , sep = ';'),logdata))
}
if (SDate!=RepDate.1())
{
extension <- ".CSV"
try(logdata <- (read.csv(paste(Serial, as.character(RDate,format="%Y%m%d"), extension, sep = "") , sep = ';')))
RDate <-RDate-86400
logdata <- (rbind(read.csv(paste(Serial, as.character(RDate,format="%Y%m%d"), extension, sep = "") , sep = ';'),logdata))
RDate <-RDate+172800
if (RDate==SDate)
{extension <- ".ACL"}
try(logdata <- (rbind(read.csv(paste(Serial, as.character(RDate,format="%Y%m%d"), extension, sep = "") , sep = ';'),logdata)))
}
logdata <- subset(logdata, (startdate == as.character(input$RepDate,format="%Y-%m-%d")) | (readydate == as.character(input$RepDate,format="%Y-%m-%d")))
logdata$jobname <- sub(":.*", "", logdata$jobname)
logdata$starttime.ct <- as.POSIXct(paste(logdata$startdate, logdata$starttime, sep = " ", format = "%Y%m%d %H:%M:%S", tz="US/Central"))
logdata$starttime.ct <- force_tz(logdata$starttime.ct,tzone="US/Central")
logdata$readytime.ct <- as.POSIXct(paste(logdata$readydate, logdata$readytime, sep = " ", format = "%Y%m%d %H:%M:%S", tz="US/Central"))
logdata$readytime.ct <- force_tz(logdata$readytime.ct,tzone="US/Central")
logdata$idletime.ct <- as.POSIXct(logdata$idletime, format = "%H:%M:%S")
logdata$idletime.hour <-as.POSIXlt(logdata$idletime.ct)$hour + as.POSIXlt(logdata$idletime.ct)$min/60 + as.POSIXlt(logdata$idletime.ct)$sec/3600
logdata$activetime.ct <- as.POSIXct(logdata$activetime, format = "%H:%M:%S")
logdata$activetime.hour <-as.POSIXlt(logdata$activetime.ct)$hour + as.POSIXlt(logdata$activetime.ct)$min/60 + as.POSIXlt(logdata$activetime.ct)$sec/3600
Sreadytime <- (strptime(logdata$readytime.ct,format="%Y-%m-%d %H:%M:%S"))
Sstarttime <- (strptime(logdata$starttime.ct,format="%Y-%m-%d %H:%M:%S"))
Rtime <- (Sreadytime-Sstarttime)/3600
Idletime <- (strptime(logdata$idletime.ct,format="%Y-%m-%d %H:%M:%S"))
Utilization <- sum(logdata$activetime.hour/24)
Utilization <- paste(round(Utilization*100,digits=1),"%",sep="")
output <- format(sum(logdata$nofprinteda4bw)+sum(logdata$nofprinteda3bw*2), big.mark=",")
ymax.r = (logdata$idletime.hour/(logdata$idletime.hour+logdata$activetime.hour))
logdata$jobname <- strtrim(logdata$jobname, 18)
}
if (Type=="c"){
url <- paste("http://",IP,"/xjutil/log.csv", sep="")
dat <- readLines(url)
dat <- dat[-1]
dat <- dat[-1]
varnames <- unlist(strsplit(dat[1], ","))
nvar <- length(varnames)
varnames<-make.names(varnames, unique=TRUE)
k <- 1
dat1 <- matrix(NA, ncol = nvar, dimnames = list(NULL, varnames))
while(k <= length(dat)){
k <- k + 1
#if(dat[k] == "") {k <- k + 1
#print(paste("data line", k, "is an empty string"))
if(k > length(dat)) {break}
#}
temp <- dat[k]
# checks if there are enough commas or if the line was broken
while(length(gregexpr(",", temp)[[1]]) < nvar-1){
k <- k + 1
temp <- paste0(temp, dat[k])
}
temp <- unlist(strsplit(temp, ","))
message(k)
dat1 <- rbind(dat1, temp)
}
dat1 = dat1[-1,]
logdata<-as.data.frame(dat1)
logdata$starttime.ct <-strptime(logdata$timestamp.printing,format="%Y %m %d %H %M %S", tz="US/Central")
logdata$readytime.ct <-strptime(logdata$timestamp.done.printing,format="%Y %m %d %H %M %S", tz="US/Central")
logdata$date.timestamp.printing <- as.character(substr(logdata$timestamp.printing, 1, 10))
logdata$date.timestamp.done.printing <- as.character(substr(logdata$timestamp.done.printing, 1, 10))
logdata <- subset(logdata, (date.timestamp.printing == as.character(RepDate.1(), format = "%Y %m %d")) | (date.timestamp.done.printing == as.character(RepDate.1(), format = "%Y %m %d")))
logdata$title <- sub(":.*", "", logdata$title)
logdata$activetime <- logdata$readytime.ct - logdata$starttime.ct
Utilization <- sum(logdata$activetime/86400)
Utilization <- paste(round(Utilization*100,digits=1),"%",sep="")
output<-format(sum(as.numeric(logdata$total.pages.printed)),big.mark = ",")
output<-""
ymax.r = 0
logdata$jobname <- logdata$title
logdata$jobname <- strtrim(logdata$jobname, 18)
}
if (Type=="a"){
url <- paste("http://",IP,"/logs/","?C=M;O=D", sep="")
html <- paste(readLines(url), collapse="\n")
matched <- str_match_all(html, "<a href=\"(1100.*?)\"")
links <- matched[[1]][, 2]
print(links)
for (i in links[1:15])
{
url <- paste("http://",IP,"/logs/", sep="")
url.a <- paste(url,as.character(i) ,sep = "")
print(url.a)
if (exists("logdata")){
logdata <- rbind(read.csv(url.a, header=TRUE, fill = TRUE, sep = ","), logdata)
}
else{
logdata <- read.csv(url.a, header=TRUE, fill = TRUE, sep = ",")
print(url.a)
}
}
logdata$size <- logdata$SqFt
logdata <- logdata %>% distinct(Start.time, .keep_all = TRUE)
logdata$Start.time <- strptime(logdata$Start.time, format="%a %b %d %H:%M:%S %Y")
logdata$Total.time <- as.POSIXlt(logdata$Total.time, format = "%H:%M:%S")
logdata$Total.time <- as.POSIXlt(logdata$Total.time)$hour + as.POSIXlt(logdata$Total.time)$min/60 + as.POSIXlt(logdata$Total.time)$sec/3600
logdata$readytime.ct <- as.POSIXct(logdata$Start.time)+(logdata$Total.time * 3600)
logdata$starttime.ct <- as.POSIXct(logdata$Start.time)
logdata$starttime <- strptime(logdata$starttime.ct,format="%Y-%m-%d")
logdata$End.time <- as.POSIXct(logdata$Start.time)+(logdata$Total.time * 3600)
logdata <- subset(logdata, as.character(starttime,format="%Y-%m-%d") == as.character(RepDate.1(),format="%Y-%m-%d") | (strptime(End.time,format="%Y-%m-%d") == as.character(RepDate.1(),format="%Y-%m-%d")))
Utilization <- (sum(logdata$Total.time))/60
Utilization <- paste(round(Utilization*100,digits=1),"%",sep="")
output<-0
#ymax.r = logdata$SqFt.hr/300
ymax.r = 0
logdata$jobname <- logdata$File.name
}
p<-ggplot(logdata, aes(xmin = starttime.ct, xmax = readytime.ct, ymin = 0, ymax = 1-ymax.r, fill = factor(jobname))) + geom_rect(alpha = .9) +
labs(title=paste(typeInput.1(),RepDate.1(), Utilization, output,sep=" "),x="Time of day",y="Run Time") + theme(legend.position="bottom", legend.title = element_blank(), legend.title = element_text(size=10),legend.title=element_blank()) + guides(fill=guide_legend(nrow=5)) +
scale_x_datetime(labels = date_format("%H:%M", tz="US/Central"),breaks = date_breaks("1 hour"),expand=c(0,0)) +
coord_cartesian(xlim = as.POSIXct(c(RepDate.1()+86400,RepDate.1()),format="%Y%m%d %H:%M:%S", tz="US/Central")) +
scale_y_continuous(labels=percent,expand=c(0,0),limits=c(0,1))
print(p)
file<-ggsave("myplot.pdf",device = "pdf",plot = p,width=16, height=10,paper="special")
})
output$downloadplot <- downloadHandler(
filename="myplot.pdf", # desired file name on client
content=function(con) {
file.copy("myplot.pdf", con)
}
)
outputOptions(output, "downloadplot", suspendWhenHidden=FALSE)
}
shinyApp(ui = ui, server = server)
How about this?
Here, I hardcoded choice_set variable, but I suppose you can define it using external data file.
Keys.
Keep your data in reactiveValues, so it can be referred to from server operations.
Use observeEvent(input$tabset, ...) to trigger server operation only when the tabset value has been changed.
Use updateRadioButtons to change the properties of the input components.
R
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(radioButtons("radio", "radio", c("A", "B"))),
mainPanel(
tabsetPanel(id = "tabset",
tabPanel("alphabet", value = "alpha"),
tabPanel("number", value = "number"))
)))
server <- function(input, output, session)
{
RV <- reactiveValues(
choise_set = list(
alpha = c("A", "B"),
number = c("1", "2", "3")
)
)
observeEvent(input$tabset, {
updateRadioButtons(session, "radio",
choices = RV$choise_set[[input$tabset]])
})
}
runApp(list(ui = ui, server = server))
I want to have a tooltip on my bar graph that shows detailed info about a customer when hovered over. The problem is that without a defined key the tooltip does not function and with a defined key the barplot does not function properly anymore. Here is the data I used:
CustomerData:
id;CustomerID;CLV;Gender;Channel;Age
1;1;300;male;facebook;24
2;2;2000;female;google ads;34
3;3;500;female;other;43
4;4;1300;male;google ads;34
5;5;100;male;other;46
6;6;400;female;other;32
7;7;600;female;google ads;43
8;8;1000;male;other;46
9;9;200;female;other;75
10;10;1700;male;google ads;35
11;11;1600;female;google ads;23
12;12;800;female;other;54
13;13;400;female;other;34
14;14;700;male;google ads;42
15;15;500;male;facebook;18
16;16;200;male;other;42
17;17;1900;male;google ads;46
18;18;400;female;other;23
19;19;600;male;other;45
20;20;200;female;other;42
21;21;1400;male;facebook;57
22;22;1200;female;facebook;54
Ui Code:
#this is the ui code
shinyUI(pageWithSidebar(
headerPanel("CLV Reporting"),
sidebarPanel(
navbarMenu(
checkboxGroupInput("gender", 'Gender:',
c("female" = "female",
"male" = "male"))),
navbarMenu(
checkboxGroupInput("channel", 'Channel:',
c("Facebook" = "facebook",
"Google Ads" = "google ads",
"Other" = "other"))),
navbarMenu(
sliderInput("age", "Age Range:",
min = 0, max = 100, value = c(20,50)))
),
mainPanel(
ggvisOutput("barplot"),
textOutput("mean"),
textOutput("price")
)
))
Server Code:
#this is the server code
library(ggvis)
library(dplyr)
library(ggplot2)
library(shiny)
shinyServer(function(input, output, session) {
report <- reactive({
gender <- input$gender
channel <- input$channel
minage <- input$age[1]
maxage <- input$age[2]
rep <- CustomerData %>%
filter(
Gender %in% gender,
Channel %in% channel,
Age >= minage,
Age <= maxage
)
})
#tooltip input
Customer_tooltip <- function (x) {
if (is.null(x)) return(NULL)
if (is.null(x$id)) return(NULL)
CustomerData <- isolate(report())
customer <- CustomerData[CustomerData$id == x$id, ]
paste0("<b>", "Customer ID: ", customer$CustomerID, "</b><br>",
"Gender: ", customer$Gender, "</b><br>",
"Channel: ", customer$Channel, "</b><br>",
"Age: ", customer$Age, "<br>",
"CLV: $", format(customer$CLV, big.mark = "'", scientific = FALSE)
)
}
# output
vis <- reactive({
report %>%
ggvis(x = ~factor(CustomerID), y = ~CLV) %>%
layer_bars(fillOpacity := 0.5, fillOpacity.hover := 1, key := ~id) %>%
add_tooltip(Customer_tooltip, "hover") %>%
add_axis("x", title = "Customer") %>%
add_axis("y", title = "CLV", title_offset = 60) %>%
set_options(width = 500, height = 300)
})
vis %>% bind_shiny("barplot")
output$mean <- renderText({
m <- report()
if (nrow(m) != 0) {paste("The mean CLV of the selected customers is: $", round(mean(m$CLV)))}
else {"There are no customers with these specifications."}
})
output$price <- renderText({
m <- report()
if (nrow(m) != 0) {paste("We recommend to spend $", round(mean(m$CLV)/12)*nrow(m), " on retaining these customers.")}
else {""}
})
})
I added the id column because I thought this could solve the problem (using a key which is not used by anything else in the code). Just in case you wondered why there were two variables with the exact same values ;)
(edit) I uploaded the newest version to gisthub:
https://gist.github.com/anonymous/f04325078f9c0656ab72
packages needed: shiny, ggvis, dplyr and ggplot2
I used this link to color cells in a table: R shiny color dataframe
I've tried to change this code to allow for locking the first column in a table as the user scrolls from left to right, but haven't been able to figure it out.
Can anyone help on this?
colortable <- function(htmltab, css, style="table-condensed table-bordered"){
tmp <- str_split(htmltab, "\n")[[1]]
CSSid <- gsub("\\{.+", "", css)
CSSid <- gsub("^[\\s+]|\\s+$", "", CSSid)
CSSidPaste <- gsub("#", "", CSSid)
CSSid2 <- paste(" ", CSSid, sep = "")
ids <- paste0("<td id='", CSSidPaste, "'")
for (i in 1:length(CSSid)) {
locations <- grep(CSSid[i], tmp)
tmp[locations] <- gsub("<td", ids[i], tmp[locations])
tmp[locations] <- gsub(CSSid2[i], "", tmp[locations],
fixed = TRUE)
}
tmp[1] = "<table class=\"display responsive no-wrap\" width=\"100%\" cellspacing=\"0\" cellpadding =\"0\">"
htmltab <- paste(tmp, collapse="\n")
Encoding(htmltab) <- "UTF-8"
list(
tags$style(type="text/css", paste(css, collapse="\n")),
tags$script(sprintf(
'$( "table" ).addClass( "table %s" );', style
)),
HTML(htmltab)
)
}