Related
Given a data sample and gt code to plot table below:
df <- structure(list(category = c("food", "food", "food", "food", "electronic product",
"electronic product", "electronic product", "electronic product"
), type = c("vegetable", "vegetable", "fruit", "fruit", "computer",
"computer", "other", "other"), variable = c("cabbage", "radish",
"apple", "pear", "monitor", "mouse", "camera", "calculator"),
price = c(6, 5, 3, 2.9, 2000, 10, 600, 35), quantity = c(2L,
4L, 5L, 10L, 1L, 3L, NA, 1L)), class = "data.frame", row.names = c(NA,
-8L))
To plot:
dt <- df %>%
group_by(category) %>%
gt() %>%
tab_header(
title = md("Category name")
)%>%
tab_style(
locations = cells_column_labels(columns = everything()),
style = list(
#Give a thick border below
cell_borders(sides = "bottom", weight = px(3)),
#Make text bold
cell_text(weight = "bold")
)
) %>%
tab_style(
locations = cells_row_groups(groups = everything()),
style = list(
cell_text(weight = "bold")
)
) %>%
cols_align(align = "center", columns = everything())
dt
Out:
Now I hope to custom cols_align() to align columns type, variable, price and quantity based on their datatype, if the datatype is character using center, if is number then using left.
How could I modify the code achieve that? Thanks.
cols_align() accepts tidyselect semantics, so you can use:
library(dplyr)
library(gt)
df %>%
group_by(category) %>%
gt() %>%
tab_header(
title = md("Category name")
)%>%
tab_style(
locations = cells_column_labels(columns = everything()),
style = list(
#Give a thick border below
cell_borders(sides = "bottom", weight = px(3)),
#Make text bold
cell_text(weight = "bold")
)
) %>%
tab_style(
locations = cells_row_groups(groups = everything()),
style = list(
cell_text(weight = "bold")
)
) %>%
cols_align(align = "center", columns = where(is.character)) %>%
cols_align(align = "left", columns = where(is.numeric))
I have created a gt table and I want to have a row at the bottom of the table with the sum of all the columns. I want to position this so that the row label "total" sits within an existing column (the column catchment in my example) rather than out to the side. How do I do this?
library(gt) # package for making tables
library(tidyverse)
library(webshot)
webshot::install_phantomjs()
Lake_name <- c("Okareka", "Okaro", "Okataina", "Rerewhakaaitu", "Rotokakahi", "Rotomahana", "Tarawera", "Tikitapu")
Lake_labels <- c("\u14ckareka", "\u14ckaro", "\u14ckataina", "Rerewhakaaitu", "Rotokakahi", "Rotomahana", "Tarawera", "Tikitapu")
#define catchment areas
LIDAR_areas <- c(19778484, 3679975, 62923350, 52941258, 19195848, 83698343, 145261086, 5728184) # m^2
White_SW_areas <- c(19963914.610, 3675087.968, 66900327.220, 54581284.030, 19207814.960, 83724917.460, 144895034.400, 5689356.743)
White_GW_areas <- c(12485786, 3675525, 70924376, 15180499, 13491567, 101632751, 159285183, 5604187)
Catchment_Areas <- as_tibble(cbind(Lake_labels, LIDAR_areas, White_SW_areas, White_GW_areas))
Catchment_Areas$LIDAR_areas <- as.numeric(Catchment_Areas$LIDAR_areas)
Catchment_Areas$White_SW_areas <- as.numeric(Catchment_Areas$White_SW_areas)
Catchment_Areas$White_GW_areas <- as.numeric(Catchment_Areas$White_GW_areas)
f <- function(x){(x/1000000)}
Catchment_Areas <- Catchment_Areas %>% mutate(across(c(LIDAR_areas, White_GW_areas, White_SW_areas), f))
Catchment_Areas_Table <-
Catchment_Areas %>%
gt() %>%
tab_header(title = md("**Catchment Areas (m<sup>2</sup> x 10<sup>6</sup>)**")) %>%
fmt_number(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), decimals = 2) %>%
cols_align(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), align = "right") %>%
cols_label(Lake_labels = "Catchment", LIDAR_areas = "Surface Water (LIDAR)", White_SW_areas = "Surface Water (White 2020)", White_GW_areas = "Groundwater (White 2020)") %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("bottom"),
color = "black",
weight = px(2)
)#,
#cell_fill(color = "grey")
),
locations = list(
cells_column_labels(
columns = gt::everything()
)
)
) %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("top"),
color = "black",
weight = px(2)
)#,
#cell_fill(color = "grey")
),
locations = list(
cells_title()
)
)
Catchment_Areas_Table %>% summary_rows(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), fns = list(Total = "sum"))
Option 1: Move your "Catchment"/Lake_labels column into `gt(rowname_col = "Lake_labels"), this moves them into the "stub" and aligns with the summary calculations.
Option 2: Pre-calculate the summary rows ahead of time. This means you can treat the summary row as another other cell value.
Reprex below (note that I converted your dataframe to a tribble so it's more compact to reprex, datapasta::tribble_paste() is amazing for this):
library(gt) # package for making tables
library(tidyverse)
library(webshot)
Catchment_Areas <- tibble::tribble(
~Lake_labels, ~LIDAR_areas, ~White_SW_areas, ~White_GW_areas,
"Ōkareka", 19.778484, 19.96391461, 12.485786,
"Ōkaro", 3.679975, 3.675087968, 3.675525,
"Ōkataina", 62.92335, 66.90032722, 70.924376,
"Rerewhakaaitu", 52.941258, 54.58128403, 15.180499,
"Rotokakahi", 19.195848, 19.20781496, 13.491567,
"Rotomahana", 83.698343, 83.72491746, 101.632751,
"Tarawera", 145.261086, 144.8950344, 159.285183,
"Tikitapu", 5.728184, 5.689356743, 5.604187
)
### Option 1
Catchment_Areas_Table <-
Catchment_Areas %>%
gt(rowname_col = "Lake_labels") %>%
tab_header(title = md("**Catchment Areas (m<sup>2</sup> x 10<sup>6</sup>)**")) %>%
fmt_number(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), decimals = 2) %>%
cols_align(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), align = "right") %>%
cols_label(Lake_labels = "Catchment", LIDAR_areas = "Surface Water (LIDAR)",
White_SW_areas = "Surface Water (White 2020)", White_GW_areas = "Groundwater (White 2020)") %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("bottom"),
color = "black",
weight = px(2)
) # ,
# cell_fill(color = "grey")
),
locations = list(
cells_column_labels(
columns = gt::everything()
)
)
) %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("top"),
color = "black",
weight = px(2)
)
),
locations = list(
cells_title(),
cells_stub(rows = 1)
)
) %>%
summary_rows(
columns = c(LIDAR_areas, White_GW_areas, White_SW_areas),
fns = list(Total = "sum")
)
#> Warning in if ((loc$groups %>% rlang::eval_tidy()) == "title") {: the condition
#> has length > 1 and only the first element will be used
gtsave(Catchment_Areas_Table, "rowname_tab.png")
### Option 2
# Create summary ahead of time, add to bottom of the existing df.
Catchment_Areas_Sum <- Catchment_Areas %>%
add_row(
Catchment_Areas %>%
summarise(across(LIDAR_areas:last_col(), sum)) %>%
mutate(Lake_labels = "Total")
)
Catchment_Areas_Table_Sum <-
Catchment_Areas_Sum %>%
gt() %>%
tab_header(title = md("**Catchment Areas (m<sup>2</sup> x 10<sup>6</sup>)**")) %>%
fmt_number(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), decimals = 2) %>%
cols_align(columns = c(LIDAR_areas, White_GW_areas, White_SW_areas), align = "right") %>%
cols_label(Lake_labels = "Catchment", LIDAR_areas = "Surface Water (LIDAR)",
White_SW_areas = "Surface Water (White 2020)", White_GW_areas = "Groundwater (White 2020)") %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("bottom"),
color = "black",
weight = px(2)
)
),
locations = list(
cells_column_labels(
columns = gt::everything()
)
)
) %>%
tab_style( # add black underline
style = list(
cell_borders(
sides = c("top"),
color = "black",
weight = px(2)
)
),
locations = list(
cells_title()
)
) %>%
tab_style(
style = cell_borders(
sides = c("top"), color = "black", weight = px(2)
),
locations = list(
cells_body(rows = Lake_labels == "Total")
)
)
#> Warning in if ((loc$groups %>% rlang::eval_tidy()) == "title") {: the condition
#> has length > 1 and only the first element will be used
gtsave(Catchment_Areas_Table_Sum, "pre_sum_tab.png")
Created on 2021-10-29 by the reprex package (v2.0.1)
Attempting to build off of Stack Exchange Question:
R Highcharter: tooltip customization
Have a R module (below). That ingests some data and provides the UI including highcharter visualizations.
consolidatedlogModuleUI <- function(id){
ns <- NS(id)
tagList(
fluidRow(
bs4Card(highchartOutput(ns("fundedbydayChart")),
width = 12,
collapsible = TRUE)
),
fluidRow(
bs4TabCard(title = "Consolidated Log",
elevation = 2,
width = 12,
bs4TabPanel(
tabName = "tab1",
active = TRUE,
DT::dataTableOutput(ns("consolidatedlogTable"))
),
bs4TabPanel(
tabName = "tab2",
active = FALSE,
DT::dataTableOutput(ns("daysummaryTable"))
)
)
)
)
}
#######
# Consolidated Log Server Module
#######
consolidatedlogModule <- function(input,output,session,data){
ns <- session$ns
data$HasGap <- ifelse(data$GAPGrossRevenue > 0, 1, 0)
data$HasESC <- ifelse(data$ESCGrossRevenue > 0, 1, 0)
consolidatedLogVariables <- c("AcctID", "FSR", "DocSentDate", "DocsToLenderDate",
"FundedDate", "HasGap", "HasESC", "LoanRevenue")
logSummary <- data %>%
group_by(FundedMonthGroup) %>%
summarise(TotalCount = n()
, TotalAmount = sum(LoanRevenue)
, TotalGAP = sum(HasGap)
, TotalESC = sum(HasESC))
daySummary <- data %>%
group_by(FundedDayGroup) %>%
summarise(TotalCount = n()
,TotalAmount = sum(LoanRevenue))
### Consolidated Log Table
output$consolidatedlogTable = DT::renderDataTable({
data[consolidatedLogVariables]
}, extensions = "Responsive", rownames = FALSE,
caption = "Current Consolidated Log",
filter = "bottom"
)
output$daysummaryTable = DT::renderDataTable({
daySummary
}, extensions = "Responsive", rownames = FALSE,
caption = "Current Consolidated Log",
filter = "bottom"
)
### Charts
#Fundedbyday Chart
output$fundedbydayChart = renderHighchart({
highchart() %>%
hc_add_theme(hc_theme_ffx()) %>%
hc_title(text = "Loans Funded By Day") %>%
hc_add_series(data = daySummary, mapping = hcaes(x=FundedDayGroup, y=TotalAmount), type = "column", name = "Daily Loan Revenue",
tooltip = list(pointFormat = "Daily Revenue ${point.TotalAmount} across {point.TotalCount} deals")) %>%
hc_tooltip(crosshairs = TRUE)
# highchart() %>%
# hc_add_theme(hc_theme_ffx()) %>%
# hc_title(text = "Loans Funded By Day") %>%
# hc_add_series(daySummary$TotalAmount, type = "column", name = "Daily Loan Revenue",
# tooltip = list(pointFormat = "Daily Revenue ${point.TotalAmount} across {point.TotalCount} deals")) %>%
# hc_tooltip()
#hchart(daySummary, "column", hcaes(daySummary$FundedDayGroup, daySummary$TotalAmount))
})
}
The highChart function that is commented out works correctly in displaying the columns wanted. The Axis is incorrect and the tooltips is unformatted but the data displays.
Using the Non-commented highchart with the HCAES call and other items, the plot is displayed without any data.
Below is code to reproduce the test data set for the daySummary, the dataframe in question.
FundedDayGroup <- as.Date(c('2019-02-01', '2019-02-4', '2019-02-05'))
TotalCount <- c(1,13,18)
TotalAmount <- c(0, 13166, 15625)
daySummary <- data.frame(FundedDayGroup, TotalCount, TotalAmount)
The issue ended up being Highcharter not interpreting the POSIXct format of the dates and needing to cast the date variable using as.Date. Additionally added some logic to handle the xAxis and setting the datetime. Code below
highchart() %>%
hc_add_theme(hc_theme_ffx()) %>%
hc_title(text = "Loans Funded By Day") %>%
hc_add_series(data = daySummary, mapping = hcaes(x=as.Date(FundedDayGroup), y=TotalAmount), type = "column", name = "Daily Loan Revenue",
tooltip = list(pointFormat = "Daily Revenue ${point.TotalAmount} across {point.TotalCount} deals")) %>%
hc_xAxis(type = "datetime", labels=list(rotation = -45, y = 40) ) %>%
hc_yAxis(title=list(text = "Revenue")) %>%
hc_tooltip(crosshairs = TRUE)
I am working with shiny and have a sliderInput() and selectInput() inside my ui.R file. I would like that based on the user choice of these both fields, to plot the selected data within hchart function. I am very close to solve the problem, but with my code, its just filtering the first number and the last number of the year and not everything between. I tried with the between function but it didnt work.
This is my ui.R code:
tabItem(tabName = "crimetypesbyyear",
fluidRow(
box(
title = "Date",
status = "primary",
solidHeader = TRUE,
width = 6,
sliderInput("ctypeDate", label = "Select Year", min = 2001, max = 2016, step = 1, sep = '', value = c(2001,2016))
),
box(
title = "Crime Type",
status = "primary",
solidHeader = TRUE,
width = 6,
height = 162,
selectInput("ctypeCrimeType", label= "Select Crime Type", choices = unique(cc$Primary.Type))
),
box(
title = "Plot",
status = "danger",
solidHeader = TRUE,
width = 12,
highchartOutput(outputId = "ctypeOutput")
),
And this is my server.R code:
output$ctypeOutput <- renderHighchart({
ctypeAnalysis <- cc[cc$Primary.Type == input$ctypeCrimeType,] %>% group_by(Year2) %>% summarise(Total = n()) %>% filter(Year2 %in% cbind(input$ctypeDate[1],input$ctypeDate[2]))
hchart(ctypeAnalysis %>% na.omit(), "column", hcaes(x = Year2, y = Total, color = Total)) %>%
hc_exporting(enabled = TRUE, filename = paste(input$ctypeCrimeType, "by_Year", sep = "_")) %>%
hc_title(text = paste("Crime Type by Year",input$ctypeCrimeType, sep = ": ")) %>%
hc_subtitle(text = "(2001 - 2016)") %>%
hc_xAxis(title = list(text = "Year")) %>%
hc_yAxis(title = list(text = "Crimes")) %>%
hc_colorAxis(stops = color_stops(n = 10, colors = c("#d98880", "#85c1e9", "#82e0aa"))) %>%
hc_add_theme(hc_theme_smpl()) %>%
hc_legend(enabled = FALSE)
})
So this line of code should be corrected: ctypeAnalysis <- cc[cc$Primary.Type == input$ctypeCrimeType,] %>% group_by(Year2) %>% summarise(Total = n()) %>% filter(Year2 %in% cbind(input$ctypeDate[1],input$ctypeDate[2])), somebody any idea?
Since Year 2 is formatted as a factor, you need to convert it back to numeric values. You can do this in the same step as the filtering function, like so:
... filter(as.numeric(levels(Year2))[Year2] >= input$ctypeDate[1] & as.numeric(levels(Year2))[Year2] <= input$ctypeDate[2])
I am creating graph structure
id <- c(1,2,3,4,5,6,7,8,9)
label <- c("All", "Cat", "Dog", "Rice","Fish", "Bread","Rice","Fish", "Bread")
nodes <- data.frame(id, label)
edges <- data.frame(
from = c(1,1,2,2,2,3,3,3),
to = c(2,3,4,5,6,7,8,9)
)
visNetwork(nodes, edges, width = "100%",height = "800px") %>% visNodes(shape = "square") %>%
visEdges(arrows = "to") %>%
visInteraction(navigationButtons = TRUE)%>%
visHierarchicalLayout(levelSeparation = 200) %>%
visOptions(manipulation = TRUE)
expecting it to show up like this.
However the actual output is like this
The node positions are incorrect , I cannot manually move the nodes and this makes it very hard to explain. Need help rearranging the nodes based on the expected output above.
You can specify the level for each node to get the orientation you want.
library(visNetwork)
id <- c(1,2,3,4,5,6,7,8,9)
label <- c("All", "Cat", "Dog", "Rice","Fish", "Bread","Rice","Fish", "Bread")
nodes <- data.frame(id, label, level = c( 1,2,2,3,3,3,3,3,3))
edges <- data.frame(
from = c(1,1,2,2,2,3,3,3),
to = c(2,3,4,5,6,7,8,9)
)
visNetwork(nodes, edges, width = "100%",height = "800px") %>% visNodes(shape = "square") %>%
visEdges(arrows = "to") %>%
visInteraction(navigationButtons = TRUE)%>%
visHierarchicalLayout(levelSeparation = 200) %>%
visOptions(manipulation = TRUE)