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()
}
#####################################
Related
This a reprex.
dt <- data.frame(a = 1:3, b = c("a", "b", ""))
dt$sup <- paste0(dt$a, "_[", dt$b, "]") # create superscript col, enclosed in '_[]'
wb <- openxlsx::createWorkbook() # create workbook
openxlsx::addWorksheet(wb, sheetName = "data") # add sheet
openxlsx::writeData(wb, sheet=1, x=dt, xy=c(1, 1)) # write data on workbook
for(i in grep("\\_\\[([A-z0-9\\s]*)\\]", wb$sharedStrings)){
# if empty string in superscript notation, then just remove the superscript notation
if(grepl("\\_\\[\\]", wb$sharedStrings[[i]])){
wb$sharedStrings[[i]] <- gsub("\\_\\[\\]", "", wb$sharedStrings[[i]])
next # skip to next iteration
}
# insert additioanl formating in shared string
wb$sharedStrings[[i]] <- gsub("<si>", "<si><r>", gsub("</si>", "</r></si>", wb$sharedStrings[[i]]))
# find the "_[...]" pattern, remove brackets and udnerline and enclose the text with superscript format
wb$sharedStrings[[i]] <- gsub("\\_\\[([A-z0-9\\s]*)\\]", "</t></r><r><rPr><vertAlign val=\"superscript\"/></rPr><t xml:space=\"preserve\">\\1</t></r><r><t xml:space=\"preserve\">", wb$sharedStrings[[i]])
}
openxlsx::saveWorkbook(wb, file="test.xlsx", overwrite = TRUE)
This is a the output from the code above:
I need to change some part of the xml code to generate bold text as this:
I tried using the formating from openxlsx package but I get:
This is the code from openxlsx formating, but it does not bold the superscript part as you see above. So I think the path for doing that is modifying the xml code in order to get it, and that's the help I need.
openxlsx::addStyle(wb, "text.xlsx",
style = openxlsx::createStyle(textDecoration = "bold"),
rows = 2:3, cols = 3, gridExpand = TRUE)
I solve this with this function with only one input:
your input texto should be in this format:
text: "normal text [superscript] ~ subscript ~" (avoid spaces between ~)
addSuperSubScriptToCell_general <- function(wb,
sheet,
row,
col,
texto,
size = '10',
colour = '000000',
font = 'Arial',
family = '2',
bold = FALSE,
italic = FALSE,
underlined = FALSE) {
placeholderText <- 'This is placeholder text that should not appear anywhere in your document.'
openxlsx::writeData(wb = wb,
sheet = sheet,
x = placeholderText,
startRow = row,
startCol = col)
#finds the string that you want to update
stringToUpdate <- which(sapply(wb$sharedStrings,
function(x){
grep(pattern = placeholderText,
x)
}
)
== 1)
#splits the text into normal text, superscript and subcript
normal_text <- str_split(texto, "\\[.*\\]|~.*~") %>% pluck(1) %>% purrr::discard(~ . == "")
sub_sup_text <- str_extract_all(texto, "\\[.*\\]|~.*~") %>% pluck(1)
if (length(normal_text) > length(sub_sup_text)) {
sub_sup_text <- c(sub_sup_text, "")
} else if (length(sub_sup_text) > length(normal_text)) {
normal_text <- c(normal_text, "")
}
# this is the separated text which will be used next
texto_separado <- map2(normal_text, sub_sup_text, ~ c(.x, .y)) %>%
reduce(c) %>%
purrr::discard(~ . == "")
#formatting instructions
sz <- paste('<sz val =\"',size,'\"/>',
sep = '')
col <- paste('<color rgb =\"',colour,'\"/>',
sep = '')
rFont <- paste('<rFont val =\"',font,'\"/>',
sep = '')
fam <- paste('<family val =\"',family,'\"/>',
sep = '')
#if its sub or sup adds the corresponding xml code
sub_sup_no <- function(texto) {
if(str_detect(texto, "\\[.*\\]")){
return('<vertAlign val=\"superscript\"/>')
} else if (str_detect(texto, "~.*~")) {
return('<vertAlign val=\"subscript\"/>')
} else {
return('')
}
}
#get text from normal text, sub and sup
get_text_sub_sup <- function(texto) {
str_remove_all(texto, "\\[|\\]|~")
}
#formating
if(bold){
bld <- '<b/>'
} else{bld <- ''}
if(italic){
itl <- '<i/>'
} else{itl <- ''}
if(underlined){
uld <- '<u/>'
} else{uld <- ''}
#get all properties from one element of texto_separado
get_all_properties <- function(texto) {
paste0('<r><rPr>',
sub_sup_no(texto),
sz,
col,
rFont,
fam,
bld,
itl,
uld,
'</rPr><t xml:space="preserve">',
get_text_sub_sup(texto),
'</t></r>')
}
# use above function in texto_separado
newString <- map(texto_separado, ~ get_all_properties(.)) %>%
reduce(paste, sep = "") %>%
{c("<si>", ., "</si>")} %>%
reduce(paste, sep = "")
# replace initial text
wb$sharedStrings[stringToUpdate] <- newString
}
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 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.
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 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)
)
}