R中的Tornado/双面水平条形图，图表轴在给定值处交叉（而不是在零处交叉）
我想在R中绘制龙卷风图（双面水平条形图），用于确定性敏感性分析，我尝试了一些代码，但没有得到所需的输出 我希望实现：-R中的Tornado/双面水平条形图，图表轴在给定值处交叉（而不是在零处交叉）,r,ggplot2,bar-chart,R,Ggplot2,Bar Chart,我想在R中绘制龙卷风图（双面水平条形图），用于确定性敏感性分析，我尝试了一些代码，但没有得到所需的输出 我希望实现：- 绘图应按敏感参数的降序排列（即，最宽的间隔应显示在图表顶部-为了获得灵敏度，我们首先计算下限值和上限值的绝对差值，我在数据帧代码中称之为“UL_差值”） 中心不应为零，但应为给定值，称为“基本情况”或我的结果表的核心/最终结果（我们希望使用参数的下限值和上限值检查不同固定参数的影响，并生成下限值和上限值的核心结果）。Excel VBA中的示例代码为 该图的标题应为“药物A与药物
Base_Result <- results.table[5,4] # Base/Core result (which I have not used in my codes below yet)
Drug_AP <- seq(1, 48, 4)
D_AP <- data.frame(OWSA[Drug_AP,]) # OWSA[] is a 10x3 matrix with 'Lower_Bound', 'Upper_Bound' and Absolute Difference of the LB and UB termed as 'UL_Difference' (row names are parameters)
DSA_Drug_AP <- D_AP[order(D_AP$UL_Difference, decreasing = T),] # Ordering the data.frame above in Descending order of 'UL_Difference'
cat("DSA Table: Drug A vs P \n")
library(formattable)
print(accounting(as.matrix(DSA_Drug_AP), digits = 0, format = "f", big.mark = ","), right = T) # Just printing the above data.frame
#另外，我使用的数据如下所示：-
Base_Result我不久前用geom_bar（）
尝试过这样做，但并不有趣<默认情况下，code>geom_bar（）geom\u rect（）xminxmaxyminymaxgeom_bar（）的问题要少得多）
因为您没有发布数据集，所以我创建了一个非常简单的数据集。但希望这个结构和你的足够接近
编辑：我更改了代码，将数据帧包含在示例中
library(ggplot2)
library(plyr)
library(dplyr)
library(tidyverse)
# this is throwing some warnings in my computer, but it is reading the data frame correctly
df <- '
Parameter Lower_Bound Upper_Bound UL_Difference
Parameter01 8074 11181 3108
Parameter02 8177 11007 2831
Parameter03 8879 10188 1308
Parameter04 4358 18697 14339
Parameter05 9073 10087 1013
Parameter06 12034 7572 4462
Parameter07 11357 7933 3423
Parameter08 9769 9202 567
Parameter09 8833 10403 1570
Parameter10 13450 4219 9231
Parameter11 10691 7915 2776
Parameter12 10036 8792 1244
' %>% read_table2()
# original value of output
base.value <- 9504
# get order of parameters according to size of intervals
# (I use this to define the ordering of the factors which I then use to define the positions in the plot)
order.parameters <- df %>% arrange(UL_Difference) %>%
mutate(Parameter=factor(x=Parameter, levels=Parameter)) %>%
select(Parameter) %>% unlist() %>% levels()
# width of columns in plot (value between 0 and 1)
width <- 0.95
# get data frame in shape for ggplot and geom_rect
df.2 <- df %>%
# gather columns Lower_Bound and Upper_Bound into a single column using gather
gather(key='type', value='output.value', Lower_Bound:Upper_Bound) %>%
# just reordering columns
select(Parameter, type, output.value, UL_Difference) %>%
# create the columns for geom_rect
mutate(Parameter=factor(Parameter, levels=order.parameters),
ymin=pmin(output.value, base.value),
ymax=pmax(output.value, base.value),
xmin=as.numeric(Parameter)-width/2,
xmax=as.numeric(Parameter)+width/2)
# create plot
# (use scale_x_continuous to change labels in y axis to name of parameters)
png(width = 960, height = 540)
ggplot() +
geom_rect(data = df.2,
aes(ymax=ymax, ymin=ymin, xmax=xmax, xmin=xmin, fill=type)) +
theme_bw() +
theme(axis.title.y=element_blank(), legend.position = 'bottom',
legend.title = element_blank()) +
geom_hline(yintercept = base.value) +
scale_x_continuous(breaks = c(1:length(order.parameters)),
labels = order.parameters) +
coord_flip()
dev.off()
库（ggplot2）
图书馆（plyr）
图书馆（dplyr）
图书馆（tidyverse）
#这会在我的计算机中抛出一些警告，但它正在正确读取数据帧
df%读取_表2（）
#产值原值
基本价值%
突变（参数=因子（x=参数，级别=参数））%>%
选择（参数）%%>%unlist（）%%>%levels（）
#绘图中列的宽度（值介于0和1之间）
宽度%
#只是重新排列列
选择（参数、类型、输出值、UL_差异）%>%
#为几何矩形创建列
突变（参数=因子（参数，级别=顺序参数），
ymin=pmin（输出值、基值），
ymax=pmax（输出值、基值），
xmin=as.数值（参数）-宽度/2，
xmax=as.数值（参数）+宽度/2）
#创建绘图
#（使用“缩放x连续”将y轴上的标签更改为参数名称）
png（宽=960，高=540）
ggplot（）+
几何校正（数据=df.2，
aes（ymax=ymax，ymin=ymin，xmax=xmax，xmin=xmin，fill=type））+
主题_bw（）+
主题（axis.title.y=element_blank（），legend.position='bottom'，
legend.title=元素_blank（））+
geom_hline（yintercept=base.value）+
比例x连续（中断=c（1：长度（顺序参数）），
标签=订单参数）+
coord_flip（）
发展主任（）
这里有一个函数，可以使用ggplot2:：geom_col（）以及一些使用示例生成龙卷风图。希望能有帮助
# Tornado Plot using ggplot2(), 2019/05/19.
# See Wikipedia: ["Tornado diagram"](https://en.wikipedia.org/wiki/Tornado_diagram).
library( magrittr )
library( tidyverse )
# Function tornado_plot() produces a "tornado plot" given the sensitivity
# analysis results in data_frame df. It plots green bars indicating the levels
# of the response variable when each **x input variable** is moved to its maximum
# level while holding all other variables constant. Similarly, the red bars are
# the outputs when each **x input variable** is moved to its minimum value while
# holding all other variables constant. The input variable to which the output
# is most sensitive is shown at the top of the plot. And the bars are stacked
# from most sensitive to least sensitive, fancifully yielding the shape of a
# tornado.
tornado_plot <-
function(
df,
var_names_col,
min_level_col,
min_output_col,
max_level_col,
max_output_col,
base_level_col,
baseline_output,
title_str = "Tornado Plot",
subtitle_str = "",
caption_str = "",
ylab_str = "output",
baseline_label = "",
scale_breaks = NULL,
limits = NULL
) {
# + The argument df must be a tidyverse::tibble with columns referred to by all of the
# other arguments having "col" in their names.
# + The var_names_col argument must be an unquoted column name that contains characters
# naming the variables that were varied in the sensitivity analysis.
# + The level column arguments -- min_level_col, max_level_col and
# base_level_col -- must be unquoted column names that contain characters to be
# used in forming labels for each variable bar of the plot.
# + The output column arguments -- min_output_col and max_output_col -- must
# be unquoted column names that contain numerical values to be plotted as the
# extents of the bars in the plot.
# + The baseline_output argument is the numeric value of the output (response) variable
# produced by setting all of the variables to their base levels.
var_names_col <- enquo( var_names_col )
min_level_col <- enquo( min_level_col )
max_level_col <- enquo( max_level_col )
base_level_col <- enquo( base_level_col )
min_output_col <- enquo( min_output_col )
max_output_col <- enquo( max_output_col )
have_custom_y_breaks <- !any( is.null(scale_breaks) )
# Create a generic tibble as the data source for plotting.
# Sorts variables from the one to which the output was least sensitive
# to the one to which the output was most sensitive.
# Then creates labels for each variable capturing the min, base, and max
# levels of that variable.
# Finally, it centers all outputs around the baseline output so thta the
# ggplot2::geom_col() function can still work with zero-based bars.
plt_df <- df %>%
mutate(del = abs(!!max_output_col - !!min_output_col) ) %>%
arrange(del) %>%
mutate(
names = sprintf(
"%s\n(min=%s; base=%s; max=%s)",
!!var_names_col,
!!min_level_col,
!!base_level_col,
!!max_level_col
),
names = factor(names,names),
min = !!min_output_col,
max = !!max_output_col
) %>%
dplyr::select(names,min,max) %>%
gather( key = Level, value = output, -names) %>%
mutate( output = output - baseline_output, Level = factor(Level,c("min","max")) ) #%T>% print()
# Generate the tornado plot.
plt <- plt_df %>%
{
ggplot(., aes( fill = Level, x = names, y = output )) +
geom_hline(yintercept = 0, linetype = 1, size = 2, color = "darkgray") +
geom_col( alpha = 0.4, width = 0.98) +
coord_flip() + #*** NOTE THE COORDINATE FLIP ***
geom_text(aes(y = 0, label = names), size = 4, fontface = "bold" ) +
scale_x_discrete( expand = expand_scale(add = 1 ) ) +
scale_fill_manual(values = c(min = "red", max = "green") ) +
ylab( ylab_str ) +
theme( # **Hmmm, references the ACTUAL plotted (post-flipped) x-y axes. **
axis.ticks.y = element_blank(),
axis.text.y = element_blank(),
axis.title.y = element_blank(),
panel.grid.major.y = element_blank(), # Remove horizontal grid lines
panel.grid.minor.y = element_blank(),
axis.text.x = element_text( size = 14 ),
axis.title.x = element_text( size = 16 ),
title = element_text( size = 18 ),
legend.position = "bottom"
) +
labs( title = title_str, subtitle = subtitle_str, caption = caption_str )
}
# Set the pre-flipped y-axis (which gets flipped to be the x-axis in the final plot).
if( !is.null(limits) ){
y_limits = limits
} else {
y_limits = c(-max(abs(plt_df$output)),max(abs(plt_df$output)))
}
if( have_custom_y_breaks ){
plt <- plt + scale_y_continuous(
limits = y_limits,
breaks = scale_breaks,
labels = names(scale_breaks)
)
} else {
plt <- plt + scale_y_continuous(
limits = y_limits,
labels = function(x) baseline_output + x
)
}
# Add the baseline output label, if any
if(baseline_label != ""){
return(
plt +
geom_label(
data = tibble( x = 0.25, y = 0, label = baseline_label),
mapping = aes( x = x, y = y, label = label),
fontface = "bold",
show.legend = FALSE,
inherit.aes = FALSE
)
)
} else {
return( plt )
}
}
#--------------------------------------------------------------------------------
# USAGE EXAMPLE:
# Hypothetical Investment Strategy Analysis:
# These are data from a sensitivity analysis on an investment strategy that invests in an
# an S&P 500 index fund and a "safety" value-store (a 0%-real-return investment);
# protecting winnings from market with transfer to safety when strategy criteria are met.
# Disregards taxes and fees. Real values (i.e., inflation-adjusted).
sensitivity_df <- tribble(
~variable, ~min, ~base, ~max, ~Total_at_min, ~Total_base, ~Total_at_max, ~Time_period,
"Start Value", 0, 2000, 100000, 239600, 245900, 554800, "start: 1980, end: 2005",
"Monthly Investment", 0, 500, 1000, 6300, 245900, 485600, "start: 1980, end: 2005",
"Allocation to Safety", 0, 0.3, 0.5, 277800, 245900, 224700, "start: 1980, end: 2005",
"Annual Increase in Mo. Investment", 0, 0.01, 0.03, 222700, 245900, 303800, "start: 1980, end: 2005",
"Protection Rate", 0, 0.0025, 0.03, 310300, 245900, 199500, "start: 1980, end: 2005",
"Start Value", 0, 2000, 100000, 174300, 175900, 253300, "start: 1910, end: 1935",
"Monthly Investment", 0, 500, 1000, 1600, 175900, 350100, "start: 1910, end: 1935",
"Allocation to Safety", 0, 0.3, 0.5, 177700, 175900, 174600, "start: 1910, end: 1935",
"Annual Increase in Mo. Investment", 0, 0.01, 0.03, 155600, 175900, 227100, "start: 1910, end: 1935",
"Protection Rate", 0, 0.0025, 0.03, 171800, 175900, 176000, "start: 1910, end: 1935"
) %>% # Add x-input level labels (overwriting reals min, base, max with character values through mutate_at()).
mutate_at(vars(contains("Total")), ~{100*round(./100)}) %>%
mutate_at(
vars( min, base, max),
~ {
ifelse(
abs(.) >= 1000,
paste0("$",formatC(.,big.mark = ",",format = "f",digits = 0)),
sprintf(
c( "$%.0f", "$%.0f", "%.0f%%", "%.1f%%", "%.2f%%" ),
. * c(1,1,100,100,100)
)
)
}
)
# Generate the tornado plot with generic labeling and axis.
sensitivity_df %>%
filter( grepl("1980.+2005", Time_period ) ) %>%
tornado_plot(
var_names_col = variable,
min_level_col = min,
min_output_col = Total_at_min,
max_level_col = max,
max_output_col = Total_at_max,
base_level_col = base,
baseline_output = .$Total_base[[1]]
) %>% print()
# Generate the tornado plot with customized labeling and axis.
scl_limits = c(0, 6.0e5 )
sensitivity_df %>%
filter( grepl("1980.+2005", Time_period ) ) %>%
tornado_plot(
var_names_col = variable,
min_level_col = min,
min_output_col = Total_at_min,
max_level_col = max,
max_output_col = Total_at_max,
base_level_col = base,
baseline_output = .$Total_base[[1]],
title_str = "Sensitivity of Total Value to Strategy Variables",
subtitle_str = sprintf( "Time period %s", .$Time_period[[1]] ),
caption_str = "Assuming S&P 500 index & 0%-real-return 'safe harbor'",
ylab_str = "Total Value",
baseline_label = paste0("Base Case:\n$",format(100*round(.$Total_base[[1]]/100,0),big.mark = ",")),
scale_breaks = setNames(
seq(min(scl_limits), max(scl_limits), 1e5) - .$Total_base[[1]],
paste0("$",formatC(
seq(min(scl_limits), max(scl_limits), 1e5),big.mark = ",",format = "f",digits = 0)
)
),
limits = scl_limits - .$Total_base[[1]]
) %>% print()
# Generate the tornado plot for another time period, with scaling
# to be comparable with the first time period.
sensitivity_df %>%
filter( grepl("1910.+1935", Time_period ) ) %>%
tornado_plot(
var_names_col = variable,
min_level_col = min,
min_output_col = Total_at_min,
max_level_col = max,
max_output_col = Total_at_max,
base_level_col = base,
baseline_output = .$Total_base[[1]],
title_str = "Sensitivity of Total Value to Strategy Variables",
subtitle_str = sprintf( "Time period %s", .$Time_period[[1]] ),
caption_str = "Assuming S&P 500 index & 0%-real-return 'safe harbor'",
ylab_str = "Total Value",
baseline_label = paste0("Base Case:\n$",format(100*round(.$Total_base[[1]]/100,0),big.mark = ",")),
scale_breaks = setNames(
seq(min(scl_limits), max(scl_limits), 1e5) - .$Total_base[[1]],
paste0("$",formatC(
seq(min(scl_limits), max(scl_limits), 1e5),big.mark = ",",format = "f",digits = 0)
)
),
limits = scl_limits - .$Total_base[[1]]
) %>% print()
#使用ggplot2（）绘制龙卷风图，2019/05/19。
#参见维基百科：[“龙卷风图”](https://en.wikipedia.org/wiki/Tornado_diagram).
图书馆（magrittr）
图书馆（tidyverse）
#函数tornado_plot（）根据灵敏度生成“tornado plot”
#数据帧df中的分析结果。它绘制了指示标高的绿色条
#当每个**x输入变量**移动到其最大值时，响应变量的
#水平，同时保持所有其他变量不变。类似地，红色条也是
#每个**x输入变量**移动到其最小值时的输出，同时
#保持所有其他变量不变。输入变量，该变量的输出
#最敏感的显示在绘图顶部。而且这些铁条都堆起来了
#从最敏感到最不敏感，幻想地产生一个
#龙卷风。
龙卷风图%
龙卷风图(
变量名称=变量，
最小值\u级别\u列=最小值，
最小输出值=最小值时的总输出值，
最大值\u等级\u列=最大值，
最大输出值=最大值时的总输出值，
基准面标高=基准面，
基线_输出=.$Total_base[[1]]
)%%>%print（）
#生成带有自定义标签和轴的龙卷风图。
scl_限值=c（0,6.0e5）
灵敏度_df%>%
过滤器（grepl（“1980年+2005年”，时间段））%>%
龙卷风图(
变量名称=变量，
最小值\u级别\u列=最小值，
最小输出值=最小值时的总输出值，
最大值\u等级\u列=最大值，
最大输出值=最大值时的总输出值，
基准面标高=基准面，
基线输出=.$Total_base[[1]]，
title_str=“总价值对战略变量的敏感性”，
subtitle_str=sprintf（“时段%s，.$Time_period[[1]]），
caption_str=“假设标准普尔500指数和0%的实际回报率为“安全港”，
ylab_str=“总价值”，
baseline_label=paste0（“基本大小写：\n$”，格式（100*轮（.$Total_Base[[1]]]]/100,0），big.mark=“，”），
比例=设置名称(
序号（最小值（scl_限值），最大值（scl_限值），1e5）-.$Total_基数[[1]]，
粘贴0（“$”，格式C(
序号（最小值（scl_限值），最大值（scl_限值），1e5，big.mark=“，”，format=“f”，数字=0）
)
),
限额=scl_限额-.$Total_基数[[1]]
)%%>%print（）
#生成另一个时间段的龙卷风图，并进行缩放
#与第一时间段相比较。
s
# Also, the data I'm using is shown below: -
Base_Result <- 9,504 # Value of results.table[5,4] on which I get 'lower' and 'upper' limit values below (and want tornado with the origin at this base_result).
# My data.frame "D_AP" will look like (I just renamed my parameters to 1(to)12)
Lower_Bound Upper_Bound UL_Difference
Parameter_01 8,074 11,181 3,108
Parameter_02 8,177 11,007 2,831
Parameter_03 8,879 10,188 1,308
Parameter_04 4,358 18,697 14,339
Parameter_05 9,073 10,087 1,013
Parameter_06 12,034 7,572 4,462
Parameter_07 11,357 7,933 3,423
Parameter_08 9,769 9,202 567
Parameter_09 8,833 10,403 1,570
Parameter_10 13,450 4,219 9,231
Parameter_11 10,691 7,915 2,776
Parameter_12 10,036 8,792 1,244
# Once, I did sort in descending order then it will be data.frame "DSA_Drug_AP" as below: -
Lower_Bound Upper_Bound UL_Difference
Parameter_04 4,358 18,697 14,339
Parameter_10 13,450 4,219 9,231
Parameter_06 12,034 7,572 4,462
Parameter_07 11,357 7,933 3,423
Parameter_01 8,074 11,181 3,108
Parameter_02 8,177 11,007 2,831
Parameter_11 10,691 7,915 2,776
Parameter_09 8,833 10,403 1,570
Parameter_03 8,879 10,188 1,308
Parameter_12 10,036 8,792 1,244
Parameter_05 9,073 10,087 1,013
Parameter_08 9,769 9,202 567
# Please note that I need to plot the 1st and 2nd column of values
# (shown in above table in order of 3rd column as a tornado plot).
# The parameter-## names will come to the left vertical line of plot.
library(ggplot2)
library(plyr)
library(dplyr)
library(tidyverse)
# this is throwing some warnings in my computer, but it is reading the data frame correctly
df <- '
Parameter Lower_Bound Upper_Bound UL_Difference
Parameter01 8074 11181 3108
Parameter02 8177 11007 2831
Parameter03 8879 10188 1308
Parameter04 4358 18697 14339
Parameter05 9073 10087 1013
Parameter06 12034 7572 4462
Parameter07 11357 7933 3423
Parameter08 9769 9202 567
Parameter09 8833 10403 1570
Parameter10 13450 4219 9231
Parameter11 10691 7915 2776
Parameter12 10036 8792 1244
' %>% read_table2()
# original value of output
base.value <- 9504
# get order of parameters according to size of intervals
# (I use this to define the ordering of the factors which I then use to define the positions in the plot)
order.parameters <- df %>% arrange(UL_Difference) %>%
mutate(Parameter=factor(x=Parameter, levels=Parameter)) %>%
select(Parameter) %>% unlist() %>% levels()
# width of columns in plot (value between 0 and 1)
width <- 0.95
# get data frame in shape for ggplot and geom_rect
df.2 <- df %>%
# gather columns Lower_Bound and Upper_Bound into a single column using gather
gather(key='type', value='output.value', Lower_Bound:Upper_Bound) %>%
# just reordering columns
select(Parameter, type, output.value, UL_Difference) %>%
# create the columns for geom_rect
mutate(Parameter=factor(Parameter, levels=order.parameters),
ymin=pmin(output.value, base.value),
ymax=pmax(output.value, base.value),
xmin=as.numeric(Parameter)-width/2,
xmax=as.numeric(Parameter)+width/2)
# create plot
# (use scale_x_continuous to change labels in y axis to name of parameters)
png(width = 960, height = 540)
ggplot() +
geom_rect(data = df.2,
aes(ymax=ymax, ymin=ymin, xmax=xmax, xmin=xmin, fill=type)) +
theme_bw() +
theme(axis.title.y=element_blank(), legend.position = 'bottom',
legend.title = element_blank()) +
geom_hline(yintercept = base.value) +
scale_x_continuous(breaks = c(1:length(order.parameters)),
labels = order.parameters) +
coord_flip()
dev.off()
# Tornado Plot using ggplot2(), 2019/05/19.
# See Wikipedia: ["Tornado diagram"](https://en.wikipedia.org/wiki/Tornado_diagram).
library( magrittr )
library( tidyverse )
# Function tornado_plot() produces a "tornado plot" given the sensitivity
# analysis results in data_frame df. It plots green bars indicating the levels
# of the response variable when each **x input variable** is moved to its maximum
# level while holding all other variables constant. Similarly, the red bars are
# the outputs when each **x input variable** is moved to its minimum value while
# holding all other variables constant. The input variable to which the output
# is most sensitive is shown at the top of the plot. And the bars are stacked
# from most sensitive to least sensitive, fancifully yielding the shape of a
# tornado.
tornado_plot <-
function(
df,
var_names_col,
min_level_col,
min_output_col,
max_level_col,
max_output_col,
base_level_col,
baseline_output,
title_str = "Tornado Plot",
subtitle_str = "",
caption_str = "",
ylab_str = "output",
baseline_label = "",
scale_breaks = NULL,
limits = NULL
) {
# + The argument df must be a tidyverse::tibble with columns referred to by all of the
# other arguments having "col" in their names.
# + The var_names_col argument must be an unquoted column name that contains characters
# naming the variables that were varied in the sensitivity analysis.
# + The level column arguments -- min_level_col, max_level_col and
# base_level_col -- must be unquoted column names that contain characters to be
# used in forming labels for each variable bar of the plot.
# + The output column arguments -- min_output_col and max_output_col -- must
# be unquoted column names that contain numerical values to be plotted as the
# extents of the bars in the plot.
# + The baseline_output argument is the numeric value of the output (response) variable
# produced by setting all of the variables to their base levels.
var_names_col <- enquo( var_names_col )
min_level_col <- enquo( min_level_col )
max_level_col <- enquo( max_level_col )
base_level_col <- enquo( base_level_col )
min_output_col <- enquo( min_output_col )
max_output_col <- enquo( max_output_col )
have_custom_y_breaks <- !any( is.null(scale_breaks) )
# Create a generic tibble as the data source for plotting.
# Sorts variables from the one to which the output was least sensitive
# to the one to which the output was most sensitive.
# Then creates labels for each variable capturing the min, base, and max
# levels of that variable.
# Finally, it centers all outputs around the baseline output so thta the
# ggplot2::geom_col() function can still work with zero-based bars.
plt_df <- df %>%
mutate(del = abs(!!max_output_col - !!min_output_col) ) %>%
arrange(del) %>%
mutate(
names = sprintf(
"%s\n(min=%s; base=%s; max=%s)",
!!var_names_col,
!!min_level_col,
!!base_level_col,
!!max_level_col
),
names = factor(names,names),
min = !!min_output_col,
max = !!max_output_col
) %>%
dplyr::select(names,min,max) %>%
gather( key = Level, value = output, -names) %>%
mutate( output = output - baseline_output, Level = factor(Level,c("min","max")) ) #%T>% print()
# Generate the tornado plot.
plt <- plt_df %>%
{
ggplot(., aes( fill = Level, x = names, y = output )) +
geom_hline(yintercept = 0, linetype = 1, size = 2, color = "darkgray") +
geom_col( alpha = 0.4, width = 0.98) +
coord_flip() + #*** NOTE THE COORDINATE FLIP ***
geom_text(aes(y = 0, label = names), size = 4, fontface = "bold" ) +
scale_x_discrete( expand = expand_scale(add = 1 ) ) +
scale_fill_manual(values = c(min = "red", max = "green") ) +
ylab( ylab_str ) +
theme( # **Hmmm, references the ACTUAL plotted (post-flipped) x-y axes. **
axis.ticks.y = element_blank(),
axis.text.y = element_blank(),
axis.title.y = element_blank(),
panel.grid.major.y = element_blank(), # Remove horizontal grid lines
panel.grid.minor.y = element_blank(),
axis.text.x = element_text( size = 14 ),
axis.title.x = element_text( size = 16 ),
title = element_text( size = 18 ),
legend.position = "bottom"
) +
labs( title = title_str, subtitle = subtitle_str, caption = caption_str )
}
# Set the pre-flipped y-axis (which gets flipped to be the x-axis in the final plot).
if( !is.null(limits) ){
y_limits = limits
} else {
y_limits = c(-max(abs(plt_df$output)),max(abs(plt_df$output)))
}
if( have_custom_y_breaks ){
plt <- plt + scale_y_continuous(
limits = y_limits,
breaks = scale_breaks,
labels = names(scale_breaks)
)
} else {
plt <- plt + scale_y_continuous(
limits = y_limits,
labels = function(x) baseline_output + x
)
}
# Add the baseline output label, if any
if(baseline_label != ""){
return(
plt +
geom_label(
data = tibble( x = 0.25, y = 0, label = baseline_label),
mapping = aes( x = x, y = y, label = label),
fontface = "bold",
show.legend = FALSE,
inherit.aes = FALSE
)
)
} else {
return( plt )
}
}
#--------------------------------------------------------------------------------
# USAGE EXAMPLE:
# Hypothetical Investment Strategy Analysis:
# These are data from a sensitivity analysis on an investment strategy that invests in an
# an S&P 500 index fund and a "safety" value-store (a 0%-real-return investment);
# protecting winnings from market with transfer to safety when strategy criteria are met.
# Disregards taxes and fees. Real values (i.e., inflation-adjusted).
sensitivity_df <- tribble(
~variable, ~min, ~base, ~max, ~Total_at_min, ~Total_base, ~Total_at_max, ~Time_period,
"Start Value", 0, 2000, 100000, 239600, 245900, 554800, "start: 1980, end: 2005",
"Monthly Investment", 0, 500, 1000, 6300, 245900, 485600, "start: 1980, end: 2005",
"Allocation to Safety", 0, 0.3, 0.5, 277800, 245900, 224700, "start: 1980, end: 2005",
"Annual Increase in Mo. Investment", 0, 0.01, 0.03, 222700, 245900, 303800, "start: 1980, end: 2005",
"Protection Rate", 0, 0.0025, 0.03, 310300, 245900, 199500, "start: 1980, end: 2005",
"Start Value", 0, 2000, 100000, 174300, 175900, 253300, "start: 1910, end: 1935",
"Monthly Investment", 0, 500, 1000, 1600, 175900, 350100, "start: 1910, end: 1935",
"Allocation to Safety", 0, 0.3, 0.5, 177700, 175900, 174600, "start: 1910, end: 1935",
"Annual Increase in Mo. Investment", 0, 0.01, 0.03, 155600, 175900, 227100, "start: 1910, end: 1935",
"Protection Rate", 0, 0.0025, 0.03, 171800, 175900, 176000, "start: 1910, end: 1935"
) %>% # Add x-input level labels (overwriting reals min, base, max with character values through mutate_at()).
mutate_at(vars(contains("Total")), ~{100*round(./100)}) %>%
mutate_at(
vars( min, base, max),
~ {
ifelse(
abs(.) >= 1000,
paste0("$",formatC(.,big.mark = ",",format = "f",digits = 0)),
sprintf(
c( "$%.0f", "$%.0f", "%.0f%%", "%.1f%%", "%.2f%%" ),
. * c(1,1,100,100,100)
)
)
}
)
# Generate the tornado plot with generic labeling and axis.
sensitivity_df %>%
filter( grepl("1980.+2005", Time_period ) ) %>%
tornado_plot(
var_names_col = variable,
min_level_col = min,
min_output_col = Total_at_min,
max_level_col = max,
max_output_col = Total_at_max,
base_level_col = base,
baseline_output = .$Total_base[[1]]
) %>% print()
# Generate the tornado plot with customized labeling and axis.
scl_limits = c(0, 6.0e5 )
sensitivity_df %>%
filter( grepl("1980.+2005", Time_period ) ) %>%
tornado_plot(
var_names_col = variable,
min_level_col = min,
min_output_col = Total_at_min,
max_level_col = max,
max_output_col = Total_at_max,
base_level_col = base,
baseline_output = .$Total_base[[1]],
title_str = "Sensitivity of Total Value to Strategy Variables",
subtitle_str = sprintf( "Time period %s", .$Time_period[[1]] ),
caption_str = "Assuming S&P 500 index & 0%-real-return 'safe harbor'",
ylab_str = "Total Value",
baseline_label = paste0("Base Case:\n$",format(100*round(.$Total_base[[1]]/100,0),big.mark = ",")),
scale_breaks = setNames(
seq(min(scl_limits), max(scl_limits), 1e5) - .$Total_base[[1]],
paste0("$",formatC(
seq(min(scl_limits), max(scl_limits), 1e5),big.mark = ",",format = "f",digits = 0)
)
),
limits = scl_limits - .$Total_base[[1]]
) %>% print()
# Generate the tornado plot for another time period, with scaling
# to be comparable with the first time period.
sensitivity_df %>%
filter( grepl("1910.+1935", Time_period ) ) %>%
tornado_plot(
var_names_col = variable,
min_level_col = min,
min_output_col = Total_at_min,
max_level_col = max,
max_output_col = Total_at_max,
base_level_col = base,
baseline_output = .$Total_base[[1]],
title_str = "Sensitivity of Total Value to Strategy Variables",
subtitle_str = sprintf( "Time period %s", .$Time_period[[1]] ),
caption_str = "Assuming S&P 500 index & 0%-real-return 'safe harbor'",
ylab_str = "Total Value",
baseline_label = paste0("Base Case:\n$",format(100*round(.$Total_base[[1]]/100,0),big.mark = ",")),
scale_breaks = setNames(
seq(min(scl_limits), max(scl_limits), 1e5) - .$Total_base[[1]],
paste0("$",formatC(
seq(min(scl_limits), max(scl_limits), 1e5),big.mark = ",",format = "f",digits = 0)
)
),
limits = scl_limits - .$Total_base[[1]]
) %>% print()