#' View data frames as Shiny pivot tables
#'
#' View data frames as Shiny pivot tables. This is an alternative to \code{View()} to view data frames as summarized data.
#' Additional options include sparklines and charts and multiple data metrics.
#'
#' @param df A data frame flat file to be converted to pivot format. Data should be in "long" format, with a single column of values named \code{value}.
#' The function defaults to showing the most recent object made in R.
#' @param valueName Name of series in \code{df} containing data values. Defaults to "value".
#' Can also accept an array of strings containing the names of multiple value columns in the data frame.
#' @param initCols Specify the series to be displayed as columns. If blank, defaults to the right-most series in the data frame.
#' @param initRows Specify the series to be displayed as rows. If blank, defaults to the 2nd right-most series in the data frame.
#' @param initNest Specify the series to be displayed as nested rows. If blank, no nested rows are displayed.
#' @param initTotals c("rows", "row_nests", "columns") to toggle row, nested row, or column totals.
#' @param initFilters Optional list of initial filter selections. Leave a series blank or use "Show All" to select all. Pass series names to \code{make.names()} to ensure correct use.
#' Alternatively, leave this blank on the intiial run, and use the Save Function feature after manually selecting filters.
#' @param initPivotValues Summary values to display in the pivot table. Default is \code{"sum"}, showing the total values of the underlying data.
#' Other options are \code{"mean"}, \code{"median"}, \code{"min"}, \code{"max"}, and \code{"count"}. Can also accept customize, one-input summary functions.
#' @param initMetric Optional list of the initial data metrics to display, after data is summarized using \code{initPivotValues}.
#' @param launch.browser If \code{TRUE}, the system's default web browser will be launched automatically after the app is started.
#' @import shiny
#'
#' @importFrom dplyr %>%
#'
#' @examples
#' \dontrun{
#' rspivot(GVAIndustry)
#'
#' rspivot(iris, valueName = names(iris)[1:4])
#'}
#' @export
rspivot <- function(df=.Last.value, valueName = "value",
initCols = "", initRows = "", initNest = "",
initTotals = c(),
initFilters = list(), initPivotValues = "sum",
initMetric = list(metric = "Values"),
launch.browser = FALSE) {
if(!is.data.frame(df)) {
stop("rspivot only accepts data frames.")
}
###
# Non-Reactive functions ----
###
if(length(valueName) > 1){
df0 <- df %>%
tidyr::gather(ValueNames, value, valueName) %>%
dplyr::mutate_if(is.factor, as.character)
} else{
df0 <- df %>%
dplyr::mutate_if(is.factor, as.character)
names(df0)[names(df0) == valueName] <- "value"
}
names(df0) <- make.names(names(df0))
dim_names <- names(df0)[!(names(df0) %in% c("value"))]
all.elements <- "Show All"
df.name <- deparse(substitute(df))
#For select_if()
all_na <- function(x) !all(is.na(x))
#Move value to end
df0a <- df0[, dim_names] %>%
dplyr::bind_cols(data.frame(value = df0$value, stringsAsFactors = FALSE))
##
#Create indices to preserve series ordering
##
dim_indices <- lapply(names(df0a)[names(df0a) != "value"], function(x){
dat <- tibble::tibble(series = c(as.character(unique(as.data.frame(df0a)[, x])), "*Total*")) %>%
dplyr::mutate(index = 1:nrow(.))
names(dat) <- c(x, paste0(x, "_index"))
return(dat)
})
names(dim_indices) <- names(df0a)[names(df0a) != "value"]
##
#Data editing options
##
data_pivotValues_choices <- c("Sum" = "sum", "Mean" = "mean", "Median" = "median",
"Max" = "max", "Min" = "min",
"Count" = "n")
#Custom pivotValues function
if(!(initPivotValues %in% data_pivotValues_choices)){
data_pivotValues_choices <- c(data_pivotValues_choices, initPivotValues)
}
data_metric_choices <- c("Values", "Growth", "Difference", "Shares")
dim_indices[["Metric_calc"]] <- tibble::tibble(Metric_calc = data_metric_choices,
Metric_calc_index = 1:length(data_metric_choices))
###
# UI ----
###
ui <- miniUI::miniPage(
miniUI::gadgetTitleBar("rspivot - Shiny pivot addin for RStudio"),
miniUI::miniTabstripPanel(
#Pivot tab ----
miniUI::miniTabPanel(
title = "Pivot",
icon = icon("table"),
miniUI::miniContentPanel(
scrollable = TRUE,
fluidRow(
column(width = 3,
uiOutput("ui_update_data"),
helpText("Select filters and then click the button to update the table.")
),
column(width = 2,
selectInput("PivRows", label = "Rows",
choices = NULL , selected = NULL),
checkboxInput("PivRows_tot", label = "Row Totals", value=TRUE)
),
column(width = 2,
selectInput("PivRowNest", label = "Nest Rows",
choices = NULL , selected = NULL),
checkboxInput("PivRowNest_tot", label = "Nest Totals", value=FALSE)
),
column(width = 2,
selectInput("PivCols", label = "Columns",
choices = NULL , selected = NULL),
checkboxInput("PivCols_tot", label = " Column Totals", value=FALSE)
),
column(width = 3,
div(
radioButtons("DisplayMode", label = "Display Mode",
choiceValues = list("Table", "Chart"),
choiceNames = list(list(icon("table"), "Table"), list(icon("bar-chart"), "Chart")),
inline = TRUE),
conditionalPanel(
condition = "input.DisplayMode == 'Table'",
radioButtons("PivCols_chart", label = "Column Charts",
choices = c("None" = "None", "Bars" = "bar", "Spark" = "line"),
selected = "line",
inline = TRUE)
),
conditionalPanel(
condition = "input.DisplayMode == 'Chart'",
radioButtons("PlotToggle", label = "Chart Type",
choices = c("Line" = "line", "Stacked Column" = "stacked", "Grouped Column" = "grouped"),
selected = "line", inline = TRUE)
),
style = "background-color: #efefef; padding: 5px; margins: 5px"
)#End div
)
),
fluidRow(
column(
width = 3,
uiOutput("selects")
),
column(
width = 9,
list(
span(
textOutput("need.data.frame"),
textOutput("need.valueName"),
style = "color:red; font-size:18pt"),
# actionButton("edits_save", label = "Save Edits", icon = icon("floppy-o"),
# style = "background-color:#FF4040; color:#ffffff;"),
# hr(),
#TABLE VIEW
conditionalPanel(
condition = "input.DisplayMode == 'Table'",
rhandsontable::rHandsontableOutput("hot"),
hr(),
#Save TABLE values as tribble
fluidRow(
column(width = 3,
strong("Save this table"),
helpText("Print this table to your editor to use as a data frame in analysis.")
),
column(width = 3,
textInput("tableSaveName", label = "Object name",
value = "RSsave1", placeholder = "e.g. DescriptiveName1")
),
column(width = 2,
numericInput("tableSaveRound", label = "Round output",
value = 5, min = 0, max = 10, step = 1)
),
column(width = 3,
br(),
actionButton("tableSaveGo", label = "Save to Editor", icon = shiny::icon("pen"),
style = "background-color:#4040FF; color:#ffffff;")
)
)
),
#CHART VIEW
conditionalPanel(
condition = "input.DisplayMode == 'Chart'",
fluidRow(
column(width = 12,
plotOutput("df_plot")
)
),
fluidRow(
column(width = 10),
column(width = 2,
checkboxInput("PlotLegend", label = "Show Legend",
value = TRUE))
)
),
#Resume common view
hr(),
strong("Save function call"),
helpText("Running this function next time will resume the pivot in its current state."),
verbatimTextOutput("stateSave"),
fluidRow(
column(width = 3,
actionButton("stateClipboard", label = "Copy to Clipboard", icon = icon("clipboard"))
),
column(width = 3,
radioButtons("stateWrite", label = strong("When 'Done', write function"),
choices = c("Nowhere" = 0,
"At curser position" = 1,
"At end of document" = 2),
selected = 0)),
column(width = 3),
column(width = 3)
),
br()
)
)
) #End Row
)
), #End Pivot Tab
#Data options ----
miniUI::miniTabPanel(
title = "Data Options",
icon = icon("edit"),
fluidRow(
column(width = 3,
radioButtons("dataPivValues", label = "Pivot table values",
choices = data_pivotValues_choices,
selected = initPivotValues, inline = T),
helpText("How to combine data behind the pivot table.
'Sum' is the default, showing the total values of the rows and columns.
'Mean' is useful for values that cannot be summed, such as ratios.
'Count' is useful for data validation."),
hr(),
strong("Data Metric"),
helpText("Data metrics further transform the pivot table values, as defined above."),
selectInput("dataMetric", label = "Metric",
choices = data_metric_choices, selected = "Values"),
conditionalPanel(
condition = "input.dataMetric != 'Values'",
selectInput("dataMetricSeries", label = "Metric over",
choices = NULL , selected = NULL)
),
conditionalPanel(
condition = "input.dataMetric == 'Growth' || input.dataMetric == 'Difference'",
numericInput("dataMetricLag", label = "Number of element lags",
min = 1, max = Inf, step = 1, value = 1),
helpText("Use this selection to choose how many elements to lag over when calculating the metric.\n
e.g. 1 means growth is calculated from the preceding value"),
conditionalPanel(
condition = "input.dataMetric == 'Growth'",
checkboxInput("dataMetricCompounded", label = "Compound growth?"),
helpText("Compound growth shows the 'average' growth over the N period selected. Leave unchecked to show total growth.")
)
)
),
# column(width = 3,
# strong("Z-scores"),
# checkboxInput("dataZscore", label = "Normalize values with Z-scores"),
# helpText("Z-scores help you find outliers in the data.
# The mean is subtracted from each data value, as defined to the left, and then divided by the standard deviation.
# The resulting Z-score is centered at 0, which each value representing the number of standard deviations from the mean.
# Large positive and negative values may be outliers."),
# hr(),
# checkboxGroupInput("dataZscoreSeries", label = "Separate Z-score analysis over:",
# choices = c("Rows"="r", "Nested Rows"="n", "Columns"="c"), selected = NULL),
# helpText("By selecting series below, the Z-score will be calculated independently for each element in those dimensions.
# This changes the means and standard deviations used in the analysis, enabling you to look for more specific outliers.")
# ),
column(width = 3,
strong("Decimals"),
numericInput("decValues", label = "Value metric", value = 0,
min = 0, max = 5, step = 1),
numericInput("decMetric", label = "Growth/Share metric", value = 1,
min = 0, max = 5, step = 1),
hr(),
selectInput("oomValues", label = "Value Order of Magnitude",
choices = c("Units" = 1, "Thousands" = 10^-3, "Millions" = 10^-6, "Billions" = 10^-9),
selected = 1)
),
column(width = 3,
strong("Text"),
numericInput("textTruncate", label = "Truncate long labels", value = 35,
min = 5, max = 100, step = 5))
)
)
)
)
###
# Server ----
###
server <- function(input, output, session) {
####
# Initialize ----
####
if(!is.data.frame(df0a)){
message("Supplied object is not a data frame.")
output$need.data.frame <- renderText({
return("Supplied object is not a data frame.")
})
} else if(!("value" %in% names(df0a))){
msg_valueName <- paste("valueName:", valueName, "not found in input dataframe. Please check function call.")
message(msg_valueName)
output$need.valueName <- renderText({
return(msg_valueName)
})
} else {
dat0 <- reactive({
dat <- df0a
return(dat)
})
}
###
#Create UI menus ----
###
#Col/Row selection
updateSelectInput(session, "PivCols",
choices = dim_names,
selected = (if(initCols == ""){utils::tail(dim_names, 1)[1]}else{make.names(initCols)})
)
updateSelectInput(session, "PivRows",
choices = dim_names,
selected = (if(initRows == ""){utils::tail(dim_names, 2)[1]}else{make.names(initRows)})
)
updateSelectInput(session, "PivRowNest",
choices = c("None", "*Metric*" = "Metric_calc", dim_names),
selected = (if(initNest == ""){"None"}else{make.names(initNest)})
)
# Totals to include
#Rows default to TRUE, others to FALSE
updateCheckboxInput(session, "PivRows_tot", value = ("rows" %in% initTotals | length(initTotals) == 0))
updateCheckboxInput(session, "PivRowNest_tot", value = "row_nests" %in% initTotals)
updateCheckboxInput(session, "PivCols_tot", value = "columns" %in% initTotals)
#Series filtering
output$selects <- renderUI({
req(dat0())
#Loop through each dimension to build a filter
lapply(seq_along(dim_names), function(i){
dat <- dat0()
if(nrow(unique(dat0()[, dim_names[i]])) <= 1){return(NULL)}
#Treat all series the same... time, nonagg, etc...
choice.list <- c(all.elements, unique(dat0()[, dim_names[i]]))
#Choose that total
choice.selected <- choice.list[1]
#Multiple allowed
choice.mult <- TRUE
#Is a numeric input?
series.num <- names(dat)[sapply(dat[, dim_names], is.numeric)]
#Is an initial input supplied
if(!is.null(initFilters[[dim_names[i]]])){
#Drop inputs that are wrong
choice.input <- initFilters[[dim_names[i]]]
# choice.input <- choice.input[choice.input == all.elements | (choice.input %in% choice.list[2])]
choice.selected <- choice.input
}
#Number input
if(dim_names[i] %in% series.num){
slide.min <- floor(min(dat[, dim_names[i]], na.rm=TRUE))
slide.max <- ceiling(max(dat[, dim_names[i]], na.rm=TRUE))
#Numeric with input
if(!is.null(initFilters[[dim_names[i]]])){
choice.min <- min(as.numeric(initFilters[[dim_names[i]]]))
choice.max <- max(as.numeric(initFilters[[dim_names[i]]]))
}
#Numeric without input
else {
choice.min <- slide.min
choice.max <- slide.max
}
}
# Build the Menu for each dimension
list(
if(dim_names[i] %in% series.num){ #Filter for numeric dimension
sliderInput(
inputId = paste0("Sel", i),
label = paste0(dim_names[i]),
min = slide.min, max = slide.max,
step = 1,
value = c(choice.min, choice.max),
sep=""
)
} else {
selectInput(
inputId = paste0("Sel", i),
label = paste0(dim_names[i]),
choices = choice.list,
selected = choice.selected,
multiple = choice.mult
)
}
) #End List
})
})
##
#Data edits
##
observe({
req(input$PivCols)
updateSelectInput(session, "dataMetricSeries",
choices = dim_names, selected = input$PivCols)
if(initMetric$metric != "Values"){
updateSelectInput(session, "dataMetric",
selected = initMetric$metric)
updateSelectInput(session, "dataMetricSeries",
selected = initMetric$series)
updateNumericInput(session, "dataMetricLag",
value = initMetric$lag)
updateCheckboxInput(session, "dataMetricCompounded",
value = initMetric$compound)
}
})
###
# Action Button
###
#Want to build the action button AFTER the menus are initialized
output$ui_update_data <- renderUI({
actionButton("update_data", label = "Refresh Data", icon = shiny::icon("refresh"),
style = "background-color:#4040FF; color:#ffffff;")
})
###
# Edit table
###
#1 - Filter
# Only update filters when clicked
dat1 <- eventReactive(input$update_data,
ignoreNULL = FALSE, {
req(dat0())
sel_col <- input$PivCols
sel_row <- input$PivRows
sel_nest <- if(input$PivRowNest %in% c("None", "Metric_calc") || input$PivRowNest == sel_row ){NULL}else{input$PivRowNest}
dat <- dat0()
datF <- dat
for(i in seq_along(dim_names)){
get_input <- eval(parse(text=paste0("input$Sel", i))) #Which filter to check
#Is a numeric input?
series.num <- names(dat)[sapply(dat[, dim_names], is.numeric)]
#If no items are selected or the Select All is selected, show ALL items
if(length(get_input) == 0 || all.elements %in% get_input){
datF <- datF
}
#For Numeric series
else if(dim_names[i] %in% series.num){
get_series <- as.numeric(get_input)
datF <- datF %>%
dplyr::filter(!!rlang::sym(dim_names[i]) >= get_series[1] & !!rlang::sym(dim_names[i]) <= get_series[2])
} else {
get_series <- as.character(get_input)
datF <- datF %>%
dplyr::filter(!!rlang::sym(dim_names[i]) %in% get_series)
}
} #End for
#After filtering, add leading space to each element...
# This helps to push all calculated fields to the bottom
datF2 <- datF %>%
dplyr::mutate_at(dplyr::vars(c(sel_row, sel_col, sel_nest)), dplyr::funs(paste0(" ", .)))
return(as.data.frame(datF))
})
#2 - ???
dat2 <- reactive({
return(dat1())
})
#3 - Reduce ----
dat3 <- reactive({
req(input$PivCols, input$PivRows, input$PivRowNest,
dat2())
sel_col <- input$PivCols
sel_row <- input$PivRows
sel_nest <- if(input$PivRowNest %in% c("None", "Metric_calc") || input$PivRowNest == sel_row ){NULL}else{input$PivRowNest}
sel_metric <- if(input$dataMetric == "Values"){NULL}else{input$dataMetricSeries}
sel_pivValues <- input$dataPivValues
dat0 <- dat2()
if(sel_pivValues %in% c("sum", "mean", "median", "min", "max")){
dat <- dat0 %>%
dplyr::group_by(!!!rlang::syms(c(sel_col, sel_row, sel_nest, sel_metric))) %>%
dplyr::summarize_at(dplyr::vars(value), sel_pivValues, na.rm=TRUE) %>%
dplyr::ungroup()
} else if(sel_pivValues == "n") {
dat <- dat0 %>%
dplyr::count(!!!rlang::syms(c(sel_col, sel_row, sel_nest, sel_metric))) %>%
dplyr::rename(value = n)
} else {
dat <- dat0 %>%
dplyr::group_by(!!!rlang::syms(c(sel_col, sel_row, sel_nest, sel_metric))) %>%
dplyr::summarize_at(dplyr::vars(value), sel_pivValues) %>%
dplyr::ungroup()
}
##
#Column & Row Totals ----
##
#Nest
dat_tot <- dat %>%
#Nested
dplyr::do(
if(!is.null(sel_nest) && sel_nest != sel_row && sel_nest != sel_col){
dplyr::bind_rows(.,
dplyr::group_by(., !!!rlang::syms(c(sel_col, sel_row))) %>%
dplyr::summarize(value = sum(value)) %>%
dplyr::ungroup()) %>%
dplyr::mutate_at(dplyr::vars(sel_nest), dplyr::funs(ifelse(is.na(.),"*Total*", .)))
} else {.}
) %>%
#Rows
dplyr::do(if(sel_row != sel_col){
dplyr::bind_rows(.,
dplyr::group_by(., !!!rlang::syms(names(.)[names(.) %in% c(sel_col, sel_nest)])) %>%
dplyr::summarize(value = sum(value)) %>%
dplyr::ungroup()) %>%
dplyr::mutate_at(dplyr::vars(sel_row), dplyr::funs(ifelse(is.na(.),"*Total*", .)))
} else {.}
) %>%
#Columns
dplyr::do(if(sel_row != sel_col){
dplyr::bind_rows(.,
dplyr::group_by(., !!!rlang::syms(names(.)[names(.) %in% c(sel_row, sel_nest)])) %>%
dplyr::summarize(value = sum(value)) %>%
dplyr::ungroup()) %>%
dplyr::mutate_at(dplyr::vars(sel_col), dplyr::funs(ifelse(is.na(.),"*Total*", .)))
} else {.}
)
return(dat_tot)
})
#4 - Modes ----
dat4 <- reactive({
req(input$PivCols, input$PivRows, input$PivRowNest,
input$dataMetricSeries,
dat3())
dat <- dat3() %>%
dplyr::mutate(value = value * as.numeric(input$oomValues))
sel_col <- input$PivCols
sel_row <- input$PivRows
sel_nest <- if(input$PivRowNest %in% c("None") || input$PivRowNest == sel_row ){NULL}else{input$PivRowNest}
sel_metric <- input$dataMetricSeries
sel_truncate <- input$textTruncate
if(input$dataMetric == "Values"){
dat <- dat %>%
dplyr::mutate(Metric_calc = "Values")
}
if(input$dataMetric == "Growth"){
#Growth lag
sel_lag <- input$dataMetricLag
if(!is.numeric(sel_lag) | sel_lag < 1){sel_lag <- 1}
#Compounded growth
sel_compound <- if(input$dataMetricCompounded){1/sel_lag}else{1}
dat <- dat %>%
dplyr::group_by(!!!rlang::syms(names(.)[!(names(.) %in% c(sel_metric, "value"))])) %>%
dplyr::mutate(Growth = ((value / dplyr::lag(value, sel_lag))^sel_compound - 1) *
(if(!is.null(sel_nest) && sel_nest =="Metric_calc"){100}else{1})
) %>%
dplyr::ungroup() %>%
dplyr::rename(Values = value) %>%
tidyr::gather(Metric_calc, value, Values, Growth)
}
if(input$dataMetric == "Difference"){
dat <- dat %>%
dplyr::group_by(!!!rlang::syms(names(.)[!(names(.) %in% c(sel_metric, "value"))])) %>%
dplyr::mutate(Difference = (value - dplyr::lag(value, 1))) %>%
dplyr::ungroup() %>%
dplyr::rename(Values = value) %>%
tidyr::gather(Metric_calc, value, Values, Difference)
}
if(input$dataMetric == "Shares"){
dat <- dat %>%
dplyr::group_by(!!!rlang::syms(names(.)[!(names(.) %in% c(sel_metric, "value"))])) %>%
dplyr::mutate(Shares = (value / sum(value)) *
(if(sel_metric %in% c(sel_col, sel_row, sel_nest)){2}else{1}) * #*2 to account for Total... this is sloppy
(if(!is.null(sel_nest) && sel_nest =="Metric_calc"){100}else{1})
) %>%
dplyr::ungroup() %>%
dplyr::rename(Values = value) %>%
tidyr::gather(Metric_calc, value, Values, Shares)
}
# # Z-score ----
# if(input$dataZscore){
# sel_zscore <- input$dataZscoreSeries
# zscore_groups <- c()
# if("r" %in% sel_zscore){zscore_groups <- c(zscore_groups, sel_row)}
# if("n" %in% sel_zscore){zscore_groups <- c(zscore_groups, sel_nest)}
# if("c" %in% sel_zscore){zscore_groups <- c(zscore_groups, sel_col)}
#
# dat <- dat %>%
# dplyr::group_by(!!!rlang::syms(zscore_groups)) %>%
# dplyr::mutate( value = (value - mean(value, na.rm=TRUE))/sd(value, na.rm=TRUE)) %>%
# dplyr::ungroup() %>%
# #Also remove totals
# dplyr::filter_all(dplyr::all_vars(. != "*Total*"))
# }
datZ <- dat %>%
dplyr::do(
if(!is.null(sel_nest) && sel_nest == "Metric_calc"){.}else{
dplyr::filter(., Metric_calc == input$dataMetric) %>%
dplyr::select(-Metric_calc) %>%
dplyr::distinct()
}
) %>%
#This time, sum over the metric'd dimension
dplyr::group_by(!!!rlang::syms(names(.)[names(.) %in% c(sel_col, sel_row, sel_nest)])) %>%
dplyr::summarize(value = sum(value)) %>%
dplyr::ungroup() %>%
dplyr::mutate_at(dplyr::vars(sel_row), as.character()) %>%
dplyr::do(
if(!is.null(sel_nest) && sel_nest != "None"){
dplyr::mutate_at(., dplyr::vars(sel_nest), as.character())
} else {.}
) %>%
dplyr::mutate_at(dplyr::vars(sel_col), as.character()) %>% #If its numeric, needs to be char before tidyr::spreading
dplyr::mutate(value = ifelse(is.nan(value) | is.infinite(value), NA, value)) %>% #Replace NaN and Inf with NA
tidyr::spread(sel_col, value)
##
#Sort data correctly
##
dat_sorted <- datZ
if(!is.null(sel_nest) && sel_nest != sel_row && sel_nest != sel_col){
dat_sorted <- dat_sorted %>%
dplyr::left_join(dim_indices[[sel_nest]], by = c(sel_nest)) %>%
dplyr:: arrange(!!!rlang::syms(paste0(sel_nest, "_index")))
}
if(sel_row != sel_col){
dat_sorted <- dat_sorted %>%
dplyr::left_join(dim_indices[[sel_row]], by = c(sel_row)) %>%
dplyr:: arrange(!!!rlang::syms(paste0(sel_row, "_index")))
}
dat_sorted <- dat_sorted %>%
dplyr::select(-dplyr::contains("_index"))
#Columns.
dat_sorted_col_order <- as.character(as.data.frame(dim_indices[[sel_col]])[, sel_col])
dat_sorted_col_order <- dat_sorted_col_order[dat_sorted_col_order %in% names(dat_sorted)]
dat_sorted_col_order <- c(if(!is.null(sel_row) && sel_row != sel_col){sel_row},
if(!is.null(sel_nest) && sel_nest != sel_row && sel_nest != sel_col){sel_nest},
dat_sorted_col_order)
dat_sorted <- dat_sorted[, dat_sorted_col_order]
return(dat_sorted)
})
###
# Prepare Data Table ----
###
cols_numeric <- reactive({
req(dat4() , input$PivCols)
dat <- as.data.frame(dat0())
cols <- as.character(names(dat4())[names(dat4()) %in% c(unique(dat[, input$PivCols]), "*Total*")])
return(cols)
})
hotData <- reactive({
sel_col <- input$PivCols
sel_row <- input$PivRows
sel_nest <- if(input$PivRowNest %in% c("None") || input$PivRowNest == sel_row ){NULL}else{input$PivRowNest}
inc_col <- input$PivCols_tot
inc_row <- input$PivRows_tot
inc_nest <- input$PivRowNest_tot
df <- dat4() %>%
#Drop NA columns
dplyr::select_if(all_na)
#Include column totals?
if(!inc_col){
df[, "*Total*"] <- NULL
}
#Include row totals?
if(sel_row != sel_col){
if(!inc_row ){
df <- df %>%
dplyr::filter(!!rlang::sym(as.name(sel_row)) != "*Total*")
}
}
#Include nest totals?
if(!is.null(sel_nest) && sel_nest != sel_row && sel_nest != sel_col){
if(!inc_nest){
df <- df %>%
dplyr::filter(!!rlang::sym(as.name(sel_nest)) != "*Total*")
}
}
return(df)
})
###
# Show pivot ----
###
output$hot <- rhandsontable::renderRHandsontable({
#Truncate text for table
sel_truncate <- input$textTruncate
df <- hotData()# %>%
# dplyr::rowwise() %>%
# dplyr::mutate_if(is.character, dplyr::funs(ifelse(nchar(.) > sel_truncate, substr(., 1, sel_truncate), .))) %>%
# dplyr::ungroup() %>%
# as.data.frame()
names(df) <- trimws(names(df))
cols_num <- names(df)[names(df) %in% cols_numeric()]
#Sparklines
if(input$PivCols_chart != "None"){
df_spk <- df %>%
dplyr::select(-dplyr::contains("*Total*"))
df$`*Chart*` <- sapply(1:nrow(df_spk), function(i){
vals <- round(as.numeric(df_spk[i, cols_num[cols_num != "*Total*"]]), 5)
vals <- vals[!is.na(vals)]
jsonlite::toJSON(list(values = vals,
options = list(type = input$PivCols_chart)))
})
}
rh <- rhandsontable::rhandsontable(df, #width = 1000, height = 500,
readOnly = TRUE) %>%
rhandsontable::hot_table(highlightCol = TRUE, highlightRow = TRUE) %>%
rhandsontable::hot_cols(columnSorting = TRUE,
fixedColumnsLeft = (if(input$PivRowNest == "None"){1}else{2}), #If nested, freeze two columns
manualColumnResize = TRUE,
renderer = "function (instance, td, row, col, prop, value, cellProperties) {
Handsontable.renderers.NumericRenderer.apply(this, arguments);
td.style.color = 'black';
}"
)
# #Heat map
# rh <- rh %>%
# rhandsontable::hot_heatmap(cols = 2:ncol(df))
if(input$dataMetric %in% c("Growth", "Shares") & input$PivRowNest != "Metric_calc"){
rh <- rh %>%
rhandsontable::hot_cols(format = paste0("0.", paste(rep("0", input$decMetric), collapse = ""), "%"))
} else {
rh <- rh %>%
rhandsontable::hot_cols(format = paste0("0.", paste(rep("0", input$decValues), collapse = "")))
}
#Sparklines
if(input$PivCols_chart != "None"){
rh <- rh %>%
rhandsontable::hot_col("*Chart*", renderer = htmlwidgets::JS("renderSparkline"), width = 80)
}
return(rh)
})
###
# Print table to editor ----
###
observeEvent(input$tableSaveGo, {
all_na <- function(x) !all(is.na(x))
saveName <- gsub("[^[:alnum:] ]", "", input$tableSaveName)
dat <- hotData() %>%
dplyr::mutate_if(is.numeric, dplyr::funs(round(., input$tableSaveRound))) %>%
as.data.frame()
rstudioapi::insertText(df_to_tribble(dat, saveName) %>% stringr::str_replace_all(" ,", "NA,"))
#Increment suggest table name as a courtesy
saveName <- gsub("\\d+$", "", saveName)
updateTextInput(session, "tableSaveName",
value = paste0(saveName, input$tableSaveGo + 1))
})
###
# Graph pivot ----
###
output$df_plot <- renderPlot({
sel_col <- input$PivCols
sel_row <- input$PivRows
sel_nest <- input$PivRowNest
sel_type <- input$PlotToggle
dat0 <- hotData()
if(sel_nest == "None" | sel_nest == sel_row){
dat <- as.data.frame(dat0) %>%
tidyr::gather(dim_x, value, 2:ncol(.))
} else {
dat <- as.data.frame(dat0) %>%
tidyr::gather(dim_x, value, 3:ncol(.))
names(dat)[names(dat) == sel_nest] <- "dim_z"
}
names(dat)[names(dat) == sel_row] <- "dim_y"
dat <- dat %>%
dplyr::filter(dim_y != "*Total*") %>%
dplyr::filter(dim_x != "*Total")
gg <- ggplot2::ggplot(data = dat, ggplot2::aes(x = dim_x, y = value, group = dim_y)) +
ggplot2::scale_x_discrete(expand = c(0,0))
#How to display data
if(sel_type == "line"){
gg <- gg +
ggplot2::geom_line(ggplot2::aes(color = dim_y), alpha = 0.75,
size = 1.1, na.rm=TRUE) +
ggplot2::scale_color_discrete( c=75, name = sel_row)
} else if(sel_type == "stacked") {
gg <- gg +
ggplot2::geom_col(ggplot2::aes(fill = dim_y), color = "black", na.rm=TRUE) +
ggplot2::scale_fill_discrete( c=75, name = sel_row)
} else {
gg <- gg +
ggplot2::geom_col(ggplot2::aes(fill = dim_y), color = "black", position = "dodge", na.rm=TRUE) +
ggplot2::scale_fill_discrete( c=75, name = sel_row)
}
#Nested?
if(!(sel_nest %in% c("None", sel_row))){
gg <- gg + ggplot2::facet_wrap(~dim_z, scales = "free")
}
gg <- gg +
ggplot2::labs(title = sel_row, x = sel_col) +
ggplot2::theme_minimal() +
ggplot2::theme(
axis.text.x = ggplot2::element_text(size = 11, angle = 90, hjust = 1),
axis.title = ggplot2::element_text(size = 13, face = "bold"),
strip.background = ggplot2::element_rect(fill = "#00436b"),
strip.text = ggplot2::element_text(color = "white", face = "bold", size = 12),
plot.title = ggplot2::element_text(color = "#00436b", face = "bold", size = 16),
plot.subtitle = ggplot2::element_text(color = "#00436b", size = 14),
plot.caption = ggplot2::element_text(size = 11)
)
if(!input$PlotLegend){
gg <- gg +
ggplot2::theme(legend.position = "none")
}
return(gg)
})
####
# Also save each filter state ----
####
stateSave_Text <- reactive({
sel_col <- input$PivCols
sel_row <- input$PivRows
sel_nest <- if(input$PivRowNest %in% c("None") || input$PivRowNest == sel_row ){NULL}else{input$PivRowNest}
dat <- dat0()
##
# Value Names
##
state_valueName <- if(valueName[1] == "value" & length(valueName) == 1){NULL}else{
paste0('valueName = c("', paste(valueName, collapse = '", "'), '"), ')
}
##
# Row/Cols
##
state_rowcol <- paste(paste0('initCols = "', sel_col, '"'),
paste0('initRows = "', sel_row, '"'),
paste0('initNest = "', sel_nest, '"'),
sep = ', ')
##
# Totals
##
state_total <- if(input$PivRows_tot & !input$PivRowNest_tot & !input$PivCols_tot){
NULL
} else {
paste0(',\n\tinitTotals = c(',
paste(c('"rows"', '"row_nests"', '"columns"')[c(input$PivRows_tot, input$PivRowNest_tot, input$PivCols_tot)],
collapse = ', '),
")"
)
}
##
# Filters
##
filterList <- c()
for(i in seq_along(dim_names)){
get_input <- eval(parse(text=paste0("input$Sel", i))) #Which filter to check
#Is a numeric input?
series.num <- names(dat)[sapply(dat[, dim_names], is.numeric)]
#If no items are selected or the Select All is selected, show ALL items
if(length(get_input) == 0 || all.elements %in% get_input){
#get_series <- all.elements
next()
}
#For Numeric series
else if(dim_names[i] %in% series.num){
get_series <- as.numeric(get_input)
} else {
get_series <- as.character(get_input)
}
if(dim_names[i] %in% series.num){ #Don't include single quotes for numeric
filterList <- c(filterList,
paste0(dim_names[i], ' = c(', paste(get_series, collapse = ', '), ')'))
} else {
filterList <- c(filterList,
paste0(dim_names[i], ' = c("', paste(get_series, collapse = '", "'), '")'))
}
} #End for
state_filter <- paste0(",\n\tinitFilters = list(", paste(filterList, collapse = ",\n\t\t"), ")")
##
# Metric
##
if(input$dataMetric == "Values"){
state_metric <- NULL
} else {
state_metric <- paste0(',\ninitMetric = list(',
'metric = "', input$dataMetric, '", ',
'series = "', input$dataMetricSeries, '"',
if(input$dataMetric %in% c("Growth", "Difference") & input$dataMetricLag > 1){
paste0(
', lag = ', input$dataMetricLag, ', ',
'compound = ', input$dataMetricCompounded
)
} else {''},
')')
}
###
# Pivot Values
###
if(input$dataPivValues == "sum"){
state_pivvalues <- NULL
} else {
state_pivvalues <- paste0(',\ninitPivotValues = "', input$dataPivValues, '"')
}
###
# Browser
###
if(!launch.browser){
state_browser <- NULL
}else {
state_browser <- paste0(',\nlaunch.browser = TRUE')
}
##
#Combine
##
state_all <- paste0("rspivot::rspivot(", df.name, ",\n\t\t",
state_valueName,
state_rowcol,
state_total,
state_filter,
state_pivvalues,
state_metric,
state_browser,
")")
# writeClipboard(state_all)
return(state_all)
})
output$stateSave <- renderText(stateSave_Text())
observeEvent(input$stateClipboard, {
if(Sys.info()["sysname"] != "Linux"){
clipr::write_clip(stateSave_Text())
}
})
# Listen for 'done' events. When we're finished, we'll
observeEvent(input$done, {
#Save function
if(input$stateWrite == 1){ #At curser
rstudioapi::insertText(stateSave_Text())
} else if(input$stateWrite == 2){ #At end
rstudioapi::insertText(Inf, stateSave_Text())
}
stopApp()
})
session$onSessionEnded(function() {
stopApp()
})
} #End Server
####
# Addin settings ----
####
if(launch.browser){
viewer <- browserViewer()
} else {
viewer <- dialogViewer(paste("RSPivot -", deparse(substitute(df))), width = 1400, height= 2000)
}
runGadget(ui, server, viewer = viewer)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.