I'm working on a script given to me and was given the following error:
Error in get_rows_id(x[[part]], i) :
invalid row selection: out of range selection
I tried searching for the get_rows_id function within the script but couldn't find it. So I ran list.files on all the packages to see where it was coming from and realized it was from the flextable package:
list.files(system.file(package = 'flextable'), recursive = T, full.names = T))
I didn't see anything using browser where flextable was used.
Is there another way non-exported functions can be called or hidden within another function in the script?
The only other way I have found to run an internal function would be
flextable:::get_rows_id
but that's a direct way I don't see in the script.
Here's the portion with flextable:
df %>%
# opts
flextable(cheight = cell_height) %>%
add_footer_lines(top = F, values = source_caption(report_quarter)) %>%
style(pr_p = def_par, pr_t = def_text, pr_c = def_cell, part = "all") %>%
style(pr_c = def_header_bg,
pr_t = def_text_header,
part = "header") %>%
style(j = 1, pr_p = update(text.align = "left", def_par),
part = "body") %>%
style(pr_p = update(text.align = "left", def_par),
pr_c = update(vertical.align = "bottom", border.bottom = fp_border(width = 0), def_cell),
pr_t = update(color = cbre_pal[2], def_text),
part = "footer") %>%
style(i = which(submarket_order %in% totals),
j = 1,
pr_t = update(bold = T, def_text)) %>%
## Row borders
border(border.top = body_border, border.bottom = body_border,
part = "body") %>%
width(width = cell_width) %>%
width(j = 1, 1.55) %>%
height(height = .28, part = "header") %>% # changed from .65
void(1, part = "header")
I wasn't able to figure out how to call the internal function other than flextable:::get_rows_id. However, I was able to solve the issue by place browser () in one of my other functions that called my df. Turns out the bug was further up in the call sequence. If you're in the same boat your best bet is to just look at everything that's interacting with said function. Hope I was able to help, good luck.
Related
The whole function which i need to convert the for loop in to apply for optimization
plans_achievements <- function(pa_m,pa_q){
if(nrow(pa_m)==0 & nrow(pa_q==0)){
df = data.frame(a = c(""), b = c("No Data Available"))
colnames(df)=""
}else{
pa_m= pa_m%>% select(inc,month_year,Plans,Achievements,quarter_year)
colnames(pa_mon)[2] = "Period"
pa_q= pa_q%>% select(inc,quarter_year,Plans,Achievements)
colnames(pa_qtr)[2] = "Period"
df = data.frame(inc=c(""),Period=c(""),Plans=c(""),Achievements=c(""))
for (q in unique(pa_q$Period)){
df1 = pa_q[pa_q$Period==q,]
df1$Period = paste0("<span style=\"color:#288D55\">",df1$Period,"</span>")
df1$Plans = paste0("<span style=\"color:#288D55\">",df1$Plans,"</span>")
df1$Achievements = paste0("<span style=\"color:#288D55\">",df1$Achievements,"</span>")
df = rbind(df,df1)
for (m in unique(pa_m$quarter_year)){
if(m==q){
df2 = pa_m[pa_m$quarter_year==q,][-5]
df = rbind(df,df2)
}
}
}
df = df[-1,]
}
return(df)
}
The apply which i tried
my_fun <- function(q){
df1 = pa_qtr[pa_qtr$Period==q,]
df1$Period = paste0("<span style=\"color:#288D55\">",df1$Period,"</span>")
df1$Plans = paste0("<span style=\"color:#288D55\">",df1$Plans,"</span>")
df1$Achievements = paste0("<span style=\"color:#288D55\">",df1$Achievements,"</span>")
df = rbind(df,df1)
}
df = do.call(rbind,lapply(unique(pa_qtr$Period), my_fun))
my_fun2 <- function(m,my_fun){
if (m == q) {
df2 = pa_mon[pa_mon$qtr_yr == q, ][-5]
df = rbind(df,df2)
}
}
df = do.call(cbind,lapply(unique(pa_mon$qtr_yr), my_fun2))
DT::datatable(plans_achievements(pa_m[pa_m$inc=="vate",],pa_q[pa_q$inc=="vate",]), rownames = F,escape = FALSE,selection=list(mode="single",target="row"),options = list(pageLength = 50,scrollX = TRUE,dom = 'tp',ordering=F,columnDefs = list(list(visible=FALSE, targets=c(0)),list(className = 'dt-left', targets = '_all'))))
Why you get the error comparison is possible only for atomic and list types
I will answer your original question first:
You get the error because you haven't defined q as a variable inside the function my_fun2. Since you haven't defined this variable, R will look for it in the global environment. There R will find the function q() (used to quit R). So you get the error message comparison (1) is possible only for atomic and list types because R thinks you are trying to compare a number m with the function q.
Here is a small example to make it easy to see:
# Run this in a clean environment
m <- 1
m == b # Understandable error message - "b" is not found
m == q # Your error - because R thinks you are comparing m to a function
You fix this error by making sure that q is defined inside your function. Either by creating it inside the function, or by supplying it as an input argument.
A possible solution for your problem
As I understand your code, you want to format, merge and sort the values in pa_q and pa_m, to display them in a html table.
Under is a possible solution, using tidyverse and vectorized operations, rather than a loop or apply functions. Vectorized functions are typically your fastest option in R, as I know you want to optimize your code.
library(dplyr)
plans_achievements <- function(pa_m, pa_q) {
# I've modified the logic a bit: there is no need to wrap the full function in
# an else statement, since we can return early if the data has no rows
if (nrow(pa_m) == 0 && nrow(pa_q == 0)) {
df = data.frame(a = c(""), b = c("No Data Available"))
colnames(df) = ""
return(df)
}
pa_q <-
pa_q %>%
# Select and rename the columns vi need
select(inc, Period = quarter_year, Plans, Achievements, date) %>%
# Format the values
mutate(
Period = paste0("<span style=\"color:#288D55\">", Period,"</span>"),
Plans = paste0("<span style=\"color:#288D55\">", Plans,"</span>"),
Achievements = paste0("<span style=\"color:#288D55\">", Achievements,"</span>")
)
pa_m <-
pa_m %>%
# Select and rename the columns we need
select(inc, Period = month_year, Plans, Achievements, date) #%>%
# Combine the datasets
bind_rows(
pa_q,
pa_m
) %>%
# Make sure that R understand date as a date value
mutate(
date = lubridate::dmy(date)
) %>%
# Sort by date
arrange(desc(date)) %>%
# Remove columns we do not need
select(-date, -inc)
}
DT::datatable(
plans_achievements(
pa_m[pa_m$inc=="vate",],
pa_q[pa_q$inc=="vate",]
),
rownames = FALSE,
escape = FALSE,
selection = list(mode = "single", target = "row"),
options = list(
pageLength = 50,
scrollX = TRUE,
dom = 'tp',
ordering = FALSE,
columnDefs = list(
list(className = 'dt-left', targets = '_all')
)
)
)
Hopefully this solves your problem.
I'm trying to build a Shiny App, everything works ok, but my issue is at the beginning, the first time that my app is launched i get an error in my highcharts due the size of the data (more than 3M of rows),
After 10 seconds the error disapear and everithing looks ok, but i want to remove the error, now i'm using waiter package, loading screeen is displayed 1.5 seconds, then the error appear and later the graph is showed .
I want to use Waiter package to hide this error until every calculation is finished. This is the Error
Below here my code for the graph
# Graph for shortInterest tab By CvsI (bars) --Dynamic
output$graph_bars_shortInterest_hc <- renderHighchart({
waiter_show(
id = "graph_bars_shortInterest_hc",
html = tagList(spin_fading_circles(),
"Loading Model ..."),
color = "#63666a",
logo = "",
hide_on_render = !is.null(id)
)
Client <- subset(Data_russel, Metrics == "marketCap") %>%
filter(Value >= input$MC_bars_[1])%>%
filter(Value <= input$MC_bars_[2])%>%
select(Client_Name) %>% unique()
Client_2 <- subset(Data_russel, Metrics == "Annual_Limit_Adequacy") %>%
filter(Value >= input$AL_filter_[1])%>%
filter(Value <= input$AL_filter_[2])%>%
select(Client_Name) %>% unique()
Data_Metric <- subset(Data_russel, Metrics == "shortInterest" & Industry %in% input$industry_CvsI_bars)
Client_filtered <- inner_join(Client, Client_2, by = "Client_Name")
Data_ <- inner_join(Client_filtered, Data_Metric, by = "Client_Name") # Clients in the range of Selected Market cap
Data_c <- subset(Data_russel, Metrics == "shortInterest" & Industry %in% input$industry_CvsI_bars & Client_Name == input$clientname_CvsI_bars)
Table_ <- seq(input$perc_range_[1], input$perc_range_[2], 1) %>% as.data.frame()
names(Table_) <- "Percentile"
Table_$Value <- round( quantile(Data_c$Value, Table_$Percentile/100), digits = 2)
Table_$Industry <- round( quantile(Data_$Value, Table_$Percentile/100), digits = 2)
hc_1 <- Table_ %>%
hchart(. , type = "line", hcaes(x = Percentile, y = Value), name = "Client", color = "#FFB81C") %>%
hc_add_series(data = Table_ ,type = 'line' , color = "#00a0d2", name = "Industry", hcaes(x = Percentile, y = Industry))%>%
hc_yAxis(opposite = TRUE) %>%
hc_title(text = "shortInterest Benchmark", margin = 30,
align = "center",
style = list(color = "#702080", useHTML = TRUE)) %>%
hc_yAxis(max = max(Table_$Industry)+(sd(Table_$Industry)/5))%>%
hc_yAxis(min = min(Table_$Industry)-(sd(Table_$Industry)/5))%>%
hc_add_theme(hc_theme_google())
hc_1
})
Thanks !!
I fixed using next function, and using each output in the UI into this function
output %>% withSpinner(
type = getOption("spinner.type", default = 3),
color.background = getOption("spinner.color.background", default = "#C8D7DF" ),
color="#00A0D2")
}```
Some days ago I found table1 library to get nice tables.
The only one problem (for me), its that output is a HTML table. I am using rtf library to export R table to word, but I dont know how export this output table (HTML) to word .
I wonder if exist some posibilty of get a different output. Or a different way to convert to R table. I am no using R-studio.
Thanks in advance.
library(table1)
table1(~mpg| carb*am,data = mtcars)
Thanks to #r2evans for the information, I could get a R table, maybe I lost a little bit the format but is ok when I export to word with rtf library:
library(rvest)
library(table1)
tbl_1=table1(~mpg| carb*am,data = mtcars)
as.data.frame(read_html(tbl_1) %>% html_table(fill=TRUE))
Note that you can get a lot more control over the output with some other packages. In the example below I'm using Tplyr and reporter. Tplyr generates the statistics and reporter will create the RTF. It takes a lot more work than table1. But you gain a lot more types of statistics and reports. You could basically produce any safety report.
library(Tplyr)
library(reporter)
dt <- tplyr_table(mtcars, am) %>%
add_layer(group_count(cyl)) %>%
add_layer(group_desc(mpg)) %>%
build()
tbl <- create_table(dt, show_cols = c("ord_layer_index", "row_label1",
"var1_0", "var1_1")) %>%
stub(c("ord_layer_index", "row_label1"), label = "Variables") %>%
define(ord_layer_index, label = "Variable", label_row = TRUE,
format = c("1" = "Cylinders",
"2" = "Miles Per Gallon"),
dedupe = TRUE, blank_after = TRUE) %>%
define(row_label1, label = "", indent = .25) %>%
define(var1_0, label = "Automatic", align = "center", n = 19) %>%
define(var1_1, label = "Manual", align = "center", n = 13)
pth <- file.path(tempdir(), "test1.rtf")
rpt <- create_report(pth,
output_type = "RTF",
orientation = "portrait") %>%
titles("Table 1.0",
"Characteristics of MTCars by Transmission Type",
"Population: All Cars") %>%
set_margins(top = 1, bottom = 1) %>%
add_content(tbl)
write_report(rpt)
file.show(pth)
Here is the RTF output:
I have some tables in Microsoft Excel that I need to recreate in an R Shiny App. The formatting in R has to remain at least mostly the same as the original context.
Here are images of the original tables:
Table 1
Table 2
Notice the formatting: There are lines under table headers and above totals, headers and totals are bolded, numbers in the Monthly Bill column have thousands seperated by commas and have dollar symbols, and the final number in Table 2 is boxed in.
If the lines were not recreatable it would be fine, but I need to at least be able to bold the selected topics, headers, and totals, and be able to get the correct number format for the Monthly Bill column.
I have tried using the DT package but I can't figure out how to format rows instead of columns. I noticed DT uses wrappers for JavaScript functions but I don't personally know JavaScript myself. Is there a way to format this the way I that I need through R packages or Javascript?
Edit:
Although it would be simple, I cannot merely include an image of the tables because some of the numbers are going to be linked to user input and must have the ability to update.
pixiedust makes it easy to do cell-specific customizations.
T1 <- data.frame(Charge = c("Environmental", "Base Power Cost",
"Base Adjustment Cost", "Distribution Adder",
"Retail Rate Without Fuel", "Fuel Charge Adjustment",
"Retail Rate With Fuel"),
Summer = c(0.00303, 0.06018, 0.00492, 0.00501, 0.07314,
0.02252, 0.09566),
Winter = c(0.00303, 0.05707, 0.00468, 0.01264, 0.07742,
0.02252, 0.09994),
Transition = c(0.00303, 0.05585, 0.00459, 0.01264,
0.07611, 0.02252, 0.09863),
stringsAsFactors = FALSE)
T2 <- data.frame(Period = c("Summer", "Winter", "Transition", "Yearly Bill"),
Rate = c(0.09566, 0.09994, 0.09863, NA),
Monthly = c(118.16, 122.44, 121.13, 1446.92),
stringsAsFactors = FALSE)
library(shiny)
library(pixiedust)
library(dplyr)
options(pixiedust_print_method = "html")
shinyApp(
ui =
fluidPage(
uiOutput("table1"),
uiOutput("table2")
),
server =
shinyServer(function(input, output, session){
output$table1 <-
renderUI({
dust(T1) %>%
sprinkle(rows = 1,
border = "bottom",
part = "head") %>%
sprinkle(rows = c(5, 7),
cols = 2:4,
border = "top") %>%
sprinkle(rows = c(5, 7),
bold = TRUE) %>%
sprinkle(pad = 4) %>%
sprinkle_colnames(Charge = "") %>%
print(asis = FALSE) %>%
HTML()
})
output$table2 <-
renderUI({
T2 %>%
mutate(Monthly = paste0("$", trimws(format(Monthly, big.mark = ",")))) %>%
dust() %>%
sprinkle(rows = 1,
border = "bottom",
part = "head") %>%
sprinkle(rows = 4,
cols = 1,
bold = TRUE) %>%
sprinkle(rows = 4,
cols = 3,
border = "all") %>%
sprinkle(na_string = "",
pad = 4) %>%
sprinkle_colnames(Period = "",
Monthly = "Monthly Bill") %>%
print(asis = FALSE) %>%
HTML()
})
})
)
This would be easier if you provided an example of your data, but sticking with DT, you should be able to utilize formatStyle to change formatting of both rows and columns. For an example to bold the first row, see the following (assuming your data frame is called df):
df %>%
datatable() %>%
formatStyle(
0,
target = "row",
fontWeight = styleEqual(1, "bold")
)
The rstudio DT page offers more examples: http://rstudio.github.io/DT/010-style.html
Alternatively, I think you might be better off using the stargazer package.
The base plot would look very similar to your desired result.
stargazer::stargazer(df, type = "html", title = "Table 1")
That will get you started, but see here for a LOT more flexibility: https://www.jakeruss.com/cheatsheets/stargazer/
I have a large shiny app that allows users to filter through an API and spark table aggregate (dumped to an .Rdata) simultaneously using the same set of initially selectized parameters. Fitting all this into a reproducible example is going to be tough, but, this is the function that is grouping and summming my metric of interest (try to resist asking me to paste in partitionFiltered()):
df <- reactive({partitionFiltered() %>%
dplyr::group_by(updatedTimeHour, direction) %>%
dplyr::mutate(count_dir = sum(n_flows)) %>%
dplyr::ungroup() %>%
dplyr::select(updatedTimeHour, direction, count_dir) %>%
dplyr::arrange(updatedTimeHour) %>%
unique()})
(Eventually, updatedTimeHour and direction will be replaced by input$periodicity and input$dimension, respectively, but that is beyond the scope of this question.)
The df() object looks like:
updatedTimeHour direction count_dir
6 1 525071.00
6 2 3491.00
6 0 498816.00
6 3 5374.00
7 2 2432.00
7 0 303818.00
7 1 340768.00
7 3 4852.00
8 1 1969048.00
My highcharter calls do not seem to be grouping and coloring the aesthetics as I would expect:
hc <- highchart() %>%
hc_add_series(data = df()$count_dir,
type = input$plot_type,
name = factor(df()$direction)
showInLegend = TRUE,
# ??group = df()$direction,
# ??color = df()$direction,
# ??x = df()$updatedTimeHour, y = df()$count_dir, color = df()$direction,
# ??hcaes(x = df()$updatedTimeHour, y = df()$count_dir, color = df()$direction)
) %>%
hc_xAxis(type = 'datetime',
# ??group = factor(df()$direction),
categories = df()$updatedTimeHour,
tickmarkPlacement = "on",
opposite = FALSE) %>%
hc_title(text = "NetFlows, by Hour",
style = list(fontWeight = "bold")) %>%
hc_exporting(enabled = TRUE, filename = "threat_extract")
As you can probably tell, I'm very confused about where/how to map the x-grouping udpatedTimeHour, or color the different direction levels appropriately and make sure their group ends up mapped correctly to the labels in the legend and hover.
I have also attempted to map these aesthetics using the hcaes() call I see included as an argument to hc_add_series() in some of the documentation, but I get errors thrown saying that that argument is not (any longer?) named in that hc_ function...
Any help is appreciated, and a related question is here.
You are trying to add as one series multiple objects that's the reason why is not working. Just changing a little bit your code and using the "magic" function hchart it should work:
df = data_frame(updatedTimeHour = c(6,6,6,6,7,7,7,7,8), direction = c(1,2,0,3,2,0,1,3,1), count_dir = rnorm(9))
type = "line"
hchart(df, type, hcaes(x = updatedTimeHour, y = count_dir, group = as.factor(direction))) %>%
hc_title(text = "NetFlows, by Hour",
style = list(fontWeight = "bold")) %>%
hc_exporting(enabled = TRUE, filename = "threat_extract")