Ciao,
I have some trouble in changing font color in my flextable.
The R version is 3.5.2
I am working on this object since I have to add the table on a pptx presentation and to do this I will of course use officer package. Let me show you a dummy code and the output:
library(officer)
library(flextable)
ppt <- read_pptx()
ppt <- add_slide( ppt, layout = "Title and Content", master = "Office Theme")
ppt <- ph_with_text(ppt, "Title whatever", type = "title")
df = head(mtcars)
ft = flextable(df)
ft <- bg(ft, i = 1, bg = "#FF0000", part = "body")
ft <- bg(ft, i = 1, bg = "#FF0000", part = "header")
ft <- fontsize(ft, i = 1, size = 15, part = "body")
ft <- fontsize(ft, i = 1, size = 20, part = "header")
ft <- color(ft, i = 1, color = "#FFFFFF", part = "body")
ft <- color(ft, i = 1, color = "white", part = "header")
ft <- font(ft, i = 1, fontname = "Consolas", part = "header")
ft <- autofit(ft)
ppt <- ph_with_flextable(ppt, ft)
if(file.exists("prova.pptx"))
file.remove("prova.pptx")
print(x = ppt, target = "prova.pptx")
As you can see I apply to the table a lot of formatting functions but I've noticed that the only one that fails is the "color" function.
The header and the first line of the table should be white. Notice that I've tried to assign to the "color" parameter both values "white" and "#FFFFFF" but in both case it does not work.
It is even more wierd considering that all other settings have been successfully applied.
What I am missing about color function from flextable package? Have you noticed the same issue (bug) ?
Thanks,
Ciao
AM
Related
I have completed the main objective of dividing the day into "cycles". Now, I am having trouble with creating a "sub cycle" within each zone that is defined. I basically am trying to take a cycle (sesionTime1) and split that at 0.38 and 0.62 be it with a vertical line that only goes from the overall session high/low, or just create another box where the start of the box is at the 0.38 and the end of the box is at 0.62. I have tried defining sessionTime1 * 0.38, but thats not working for me. And, using bar_indez(X) only focuses on the bar movement which will change as the timeframe on chart is changed.
// This source code is subject to the terms of the Mozilla Public License 2.0 at https://mozilla.org/MPL/2.0/
// © hitmanict
//#version=5
indicator("AMD", overlay=true)
//Get boolean input value (on/off buttons)
//Accumulation
inputAcc = input.bool(title = "Accumulation", defval = true, tooltip = "Turn On/Off Accumulation & Select Color", inline = "1", group = "Accumulation")
inputAccColor = input.color(title = "Box", defval = color.new(#4caf50, 90), inline = "2", group = "Accumulation")
InputAccBorder = input.color(title = "Border", defval = color.rgb(0, 0, 0, 95), inline = "2", group = "Accumulation")
inputAccSub = input.bool(title = "Accumulation Fractal", defval = true, group = "Accumulation")
sessionTime1 = input.session("1845-0330", title = "Session Time")
sessionZone1 = input.string("GMT-5", title = "Session Time Zone")
//Manipulation
inputMan = input.bool(title = "Manipulation", defval = true, tooltip = "Turn On/Off Manipulation & Select Color", inline = "3", group = "Manipulation")
inputManColor = input.color(title = "Box", defval = color.new(#ffcc80,80), inline = "4", group = "Manipulation")
InputManBorder = input.color(title = "Border", defval = color.rgb(0, 0, 0, 95), inline = "4", group = "Manipulation")
sessionTime2 = input.session("0330-0900", title = "Session Time")
sessionZone2 = input.string("GMT-5", title = "Session Time Zone")
//Distribution
inputDistro = input.bool(title = "Distribution", defval = true, tooltip = "Turn On/Off Distribution & Select Color", inline = "5", group = "Distribution")
inputDistColor = input.color(title = "Box", defval = color.new(#2962ff,95), inline = "6", group = "Distribution")
InputDistBorder = input.color(title = "Border", defval = color.rgb(0, 0, 0, 95), inline = "6", group = "Distribution")
sessionTime3 = input.session("0900-1845", title = "Session Time")
sessionZone3 = input.string("GMT-5", title = "Session Time Zone")
//InSession() returns 'true' when the current bar happens inside
//the specified session, corrected for the given time zone (optional).
//Returns 'false' when the bar doesn't happen in that time period,
//or when the chart's time frame is 1 day or higher.
InSession1(sessionTime1, sessionZone1=syminfo.timezone) => not na(time(timeframe.period, sessionTime1, sessionZone1))
InSession2(sessionTime2, sessionZone1=syminfo.timezone) => not na(time(timeframe.period, sessionTime2, sessionZone2))
InSession3(sessionTime3, sessionZone1=syminfo.timezone) => not na(time(timeframe.period, sessionTime3, sessionZone3))
//See if the session is currently active and just started
inSession1 = InSession1(sessionTime1, sessionZone1) and timeframe.isintraday
session1Start = inSession1 and not inSession1[1]
inSession2 = InSession2(sessionTime2, sessionZone2) and timeframe.isintraday
session2Start = inSession2 and not inSession2[1]
inSession3 = InSession3(sessionTime3, sessionZone3) and timeframe.isintraday
session3Start = inSession3 and not inSession3[1]
//Create variables
var session1HighPrice = 0.0
var session1LowPrice = 0.0
var session2HighPrice = 0.0
var session2LowPrice = 0.0
var session3HighPrice = 0.0
var session3LowPrice = 0.0
//When a new session starts, set high/low to the data of the bar in the session.
if session1Start
session1HighPrice := high
session1LowPrice := low
if session2Start
session2HighPrice := high
session2LowPrice := low
if session3Start
session3HighPrice := high
session3LowPrice := low
//Else, during the session, track the highest high and lowest low
else if inSession1
session1HighPrice := math.max(session1HighPrice, high)
session1LowPrice := math.min(session1LowPrice, low)
else if inSession2
session2HighPrice := math.max(session2HighPrice, high)
session2LowPrice := math.min(session2LowPrice, low)
else if inSession3
session3HighPrice := math.max(session3HighPrice, high)
session3LowPrice := math.min(session3LowPrice, low)
//Create persistent variable for the box identifier
var box session1Box = na
var box session2Box = na
var box session3Box = na
//When a session begins, make a new box for that session
if session1Start
session1Box := inputAcc ? box.new(left=bar_index, top = na, right = na, bottom = na, bgcolor = inputAccColor, border_color = InputAccBorder) : na
if session2Start
session2Box := inputMan ? box.new(left=bar_index, top = na, right = na, bottom = na, bgcolor = inputManColor, border_color = InputManBorder) : na
if session3Start
session3Box := inputDistro ? box.new(left=bar_index, top = na, right = na, bottom = na, bgcolor = inputDistColor, border_color = InputDistBorder) : na
//During the session, update that session's existing box
if inSession1
box.set_top(session1Box, session1HighPrice)
box.set_bottom(session1Box, session1LowPrice)
box.set_right(session1Box, bar_index + 1)
if inSession2
box.set_top(session2Box, session2HighPrice)
box.set_bottom(session2Box, session2LowPrice)
box.set_right(session2Box, bar_index + 1)
if inSession3
box.set_top(session3Box, session3HighPrice)
box.set_bottom(session3Box, session3LowPrice)
box.set_right(session3Box, bar_index + 1)
*//Sub AMD Section*
//Create persistent variable for the sub box identifier
var box session1BoxSub = na
var box session2BoxSub = na
var box session3BoxSub = na
if session1Start
session1BoxSub := inputAcc == inputAccSub ? box.new(left = bar_index, top = na, right = na, bottom = na, bgcolor = color.rgb(0, 187, 212, 100), border_color = color.rgb(171, 173, 177), border_style = line.style_dotted, border_width = 2) : na
if inSession1
box.set_top(session1BoxSub, session1HighPrice)
box.set_bottom(session1BoxSub, session1LowPrice)
box.set_right(session1BoxSub, bar_index + 1)
I am attempting this addition at the very bottom unde3r SUB AMD SECTION. Any help/guidance is greatly appreciated.
enter image description hereI copied the exercise code but it is for cereal, how do I change it to show air quality? I will attach a picture for reference from the book rstudio for dummies. I try inputting the data set but it throws off my app.
library(shinydashboard)
library(MASS)
ui <- dashboardPage(
dashboardHeader(title = "Brushing"),
dashboardSidebar(collapsed = TRUE),
dashboardBody(
fluidRow(
plotOutput("CerealPlot",
click = "single_click",
hover = "hovering",
brush = "brushing")
),
box((verbatimTextOutput("coords")), width = 8)
)
)
head(airquality)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$CerealPlot <- renderPlot({
plot(x=UScereal$protein, y=UScereal$calories,
xlab="Protein(gm)",
ylab="Calories",
pch=as.character(UScereal$mfr))
})
output$coords <- renderPrint({
nearPoints(UScereal, input$single_click,
xvar = "protein", yvar = "calories", threshold=20)
})
}
# Run the application
shinyApp(ui=ui, server = server)
I have a data table that contains some very wide columns and I want to add a scrolling-bar to make it more presentable. So far I have found examples using a scrolling-bar for the entire table - but ideally I would like to have a scrolling-bar for EACH column in the table if that is possible. Below there is an illustrating example. In this code I want a scrolling-bar for both "This_is_a_very_long_name_1", "This_is_a_very_long_name_2" etc.
library("shinydashboard")
library("shiny")
body <- dashboardBody(
fluidPage(
column(width = 4,
box(
title = "Box title", width = NULL, status = "primary",
div(style = 'overflow-x: scroll', tableOutput('table'))
)
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Column layout"),
dashboardSidebar(),
body
)
server <- function(input, output) {
test.table <- data.frame(lapply(1:8, function(x) {1:10}))
names(test.table) <- paste0('This_is_a_very_long_name_', 1:8)
output$table <- renderTable({
test.table
})
}
# Preview the UI in the console
shinyApp(ui = ui, server = server)
I thought about splitting the table into 8 tables, making a scrolling table for each of them and then putting them next to each other, but space was added betweeen them and it did not look that nice. I think it would be preferable to keeping it as one table (but suggestions are very welcome!).
Does anyone whether this is possible - and how to solve it?
Thanks in advance!
I would not recommend scrolling column header, i think it would not be very clear to read it or so. Here is the code which You can use to get the header in 2 lines so the columns are not too wide:
library("shinydashboard")
library("shiny")
library(DT)
test.table <- data.frame(lapply(1:8, function(x) {1:10}))
names(test.table) <- paste0('This_is_a_very_long_name_', 1:8)
body <- dashboardBody(
fluidPage(
column(width = 8,
box(
title = "Box title", width = NULL, status = "primary",
div(style = 'overflow-x: scroll', dataTableOutput('table'))
)
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Column layout"),
dashboardSidebar(),
body
)
server <- function(input, output) {
output$table <- renderDataTable({
names(test.table) <- gsub("_"," ",names(test.table))
datatable(test.table, options = list(columnDefs = list(list(width = '100px', targets = c(1:8)))))
})
}
# Preview the UI in the console
shinyApp(ui = ui, server = server)
[UPDATE] --> Column text rendering
Here is a one solution which can be usefull for You. There is no scrolling, however Your row text displays only first three characters (the number of characters displayed can be changed) and ..., with mouse over the row You get the pop up with whole variable name in this row:
library("shinydashboard")
library("shiny")
library(DT)
x <- c("aaaaaaaaaaaaaa", "bbbbbbbbbbbb", "ccccccccccc")
y <- c("aaaaaaaaaaaaaa", "bbbbbbbbbbbb", "ccccccccccc")
z <- c(1:3)
data <- data.frame(x,y,z)
body <- dashboardBody(
fluidPage(
column(width = 4,
box(
title = "Box title", width = NULL, status = "primary",
div(style = 'overflow-x: scroll', dataTableOutput('table'))
)
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Column layout"),
dashboardSidebar(),
body
)
server <- function(input, output) {
output$table <- renderDataTable({
datatable(data, options = list(columnDefs = list(list(
targets = c(1:3),
render = JS(
"function(data, type, row, meta) {",
"return type === 'display' && data.length > 3 ?",
"'<span title=\"' + data + '\">' + data.substr(0, 3) + '...</span>' : data;",
"}")),list(width = '100px', targets = c(1:3)))))
})
}
# Preview the UI in the console
shinyApp(ui = ui, server = server)
I have a list of documents to process, and for each record I want to attach some metadata to the document "member" inside the "corpus" data structure that tm, the R package, generates (from reading in text files).
This for-loop works but it is very slow,
Performance seems to degrade as a function f ~ 1/n_docs.
for (i in seq(from= 1, to=length(corpus), by=1)){
if(opts$options$verbose == TRUE || i %% 50 == 0){
print(paste(i, " ", substr(corpus[[i]], 1, 140), sep = " "))
}
DublinCore(corpus[[i]], "title") = csv[[i,10]]
DublinCore(corpus[[i]], "Publisher" ) = csv[[i,16]] #institutions
}
This may do something to the corpus variable but I don't know what.
But when I put it inside a tm_map() (similar to lapply() function), it runs much faster, but the changes are not made persistent:
i = 0
corpus = tm_map(corpus, function(x){
i <<- i + 1
if(opts$options$verbose == TRUE){
print(paste(i, " ", substr(x, 1, 140), sep = " "))
}
meta(x, tag = "Heading") = csv[[i,10]]
meta(x, tag = "publisher" ) = csv[[i,16]]
})
Variable corpus has empty metadata fields after exiting the tm_map function. It should be filled. I have a few other things to do with the collection.
The R documentation for the meta() function says this:
Examples:
data("crude")
meta(crude[[1]])
DublinCore(crude[[1]])
meta(crude[[1]], tag = "Topics")
meta(crude[[1]], tag = "Comment") <- "A short comment."
meta(crude[[1]], tag = "Topics") <- NULL
DublinCore(crude[[1]], tag = "creator") <- "Ano Nymous"
DublinCore(crude[[1]], tag = "Format") <- "XML"
DublinCore(crude[[1]])
meta(crude[[1]])
meta(crude)
meta(crude, type = "corpus")
meta(crude, "labels") <- 21:40
meta(crude)
I tried many of these calls (with var "corpus" instead of "crude"), but they do not seem to work.
Someone else once seemed to have had the same problem with a similar data set (forum post from 2009, no response)
Here's a bit of benchmarking...
With the for loop :
expr.for <- function() {
for (i in seq(from= 1, to=length(corpus), by=1)){
DublinCore(corpus[[i]], "title") = LETTERS[round(runif(26))]
DublinCore(corpus[[i]], "Publisher" ) = LETTERS[round(runif(26))]
}
}
microbenchmark(expr.for())
# Unit: milliseconds
# expr min lq median uq max
# 1 expr.for() 21.50504 22.40111 23.56246 23.90446 70.12398
With tm_map :
corpus <- crude
expr.map <- function() {
tm_map(corpus, function(x) {
meta(x, "title") = LETTERS[round(runif(26))]
meta(x, "Publisher" ) = LETTERS[round(runif(26))]
x
})
}
microbenchmark(expr.map())
# Unit: milliseconds
# expr min lq median uq max
# 1 expr.map() 5.575842 5.700616 5.796284 5.886589 8.753482
So the tm_map version, as you noticed, seems to be about 4 times faster.
In your question you say that the changes in the tm_map version are not persistent, it is because you don't return x at the end of your anonymous function. In the end it should be :
meta(x, tag = "Heading") = csv[[i,10]]
meta(x, tag = "publisher" ) = csv[[i,16]]
x
I have created a progress bar to keep tabs on the execution of some R scripts. And I want to insert a custom icon in the bar instead of the default 'Tk' one. I am able to do this on Windows using a .ico file and the following command
tcl('wm', 'iconbitmap', .win, 'Icon.ico')
But I am a loss about how to do the same in Mac OSX and Linux. Obviously, the .ico format doesn't work but neither does .png, .jpg, .bmp, .xbm or .xpm. Any suggestion on how I could proceed? Sample image and progress bar code attached below:-
Sample image http://tinypic.com/r/jt8efn/6 - http://tinypic.com/r/jt8efn/6
tkProgressBar2 <- function (title = 'Test progress bar', label = '', min = 0, max = 100, initial = 0, width = 300, userfn='helvetica', backg='white') {
useText <- FALSE
have_ttk <- as.character(tcl('info', 'tclversion')) >= '8.5'
if (!have_ttk && as.character(tclRequire('PBar')) == 'FALSE') useText <- TRUE
.win <<- tktoplevel(background=backg)
tkfocus()
tcl('wm', 'geometry', .win, '500x100+450+350')
tcl('wm', 'iconbitmap', .win, '#Icon.xbm')
.val <- initial
.killed <- FALSE
tkwm.geometry(.win, sprintf('%dx80', width + 40))
tkwm.title(.win, title)
fn <- tkfont.create(family = userfn, size = 12)
if (useText) {
.lab <- tklabel(.win, text = label, font = fn, padx = 0, background=backg)
tkpack(.lab, side = 'left')
fn2 <- tkfont.create(family = userfn, size = 16)
.vlab <- tklabel(.win, text = '0%', font = fn2, padx = 20, background=backg)
tkpack(.vlab, side = 'right')
up <- function(value) {
if (!is.finite(value) || value < min || value > max) return()
.val <<- value
tkconfigure(.vlab, text = sprintf('%d%%', round(100 * (value - min)/(max - min))))
}
} else {
.lab <- tklabel(.win, text = label, font = fn, pady = 0, background=backg)
.tkval <- tclVar(0)
tkpack(.lab, side = 'top')
tkpack(tklabel(.win, text = '', font = fn, background=backg), side = 'bottom')
pBar <- if (have_ttk)
ttkprogressbar(.win, length = width, variable = .tkval) else
tkwidget(.win, 'ProgressBar', width = width, variable = .tkval)
tkpack(pBar, side = 'bottom')
up <- function(value) {
if (!is.finite(value) || value < min || value > max) return()
.val <<- value
tclvalue(.tkval) <<- 100 * (value - min)/(max - min)
}
}
getVal <- function() .val
kill <- function() if (!.killed) {
tkdestroy(.win)
.killed <<- TRUE
}
title <- function(title) tkwm.title(.win, title)
lab <- function(label) tkconfigure(.lab, text = label)
tkbind(.win, '<Destroy>', function() stop())
up(initial)
structure(list(getVal = getVal, up = up, title = title, label = lab, kill = kill), class = 'tkProgressBar')
}
pb <- tkProgressBar2(title='Performing k-Means clustering', label='Some information in %', min=0, max=100, initial=0, width=400, userfn='verdana', backg='white')
On Linux you set the icon with wm iconphoto; wm iconbitmap does something else entirely. To do that, you'll need to create a photo image with the image data in it.
I'm guessing that you write this in R as:
tcl('wm', 'iconphoto', .win, tcl('image', 'create', 'photo', '-file', 'Icon.gif'))
I'm not quite sure which image formats are supported by the version of Tk you're using, including any image format support packages it has available. The minimal set is GIF and PPM unless you're (bravely) using 8.6, when PNG is also available by default.
(You can also create the content of a photo image programatically, but that's slow for various reasons.)
OSX doesn't have window icons in the same sense; it's normal for each minimized window to just show a snapshot of itself when it is minimized to the dock.