Related
I have a complicated equation for which I have written the code as follows:
sigma = 1.336449027;
f_t = 0.500185113;
alpha = 0.364; #elasticity of capital
beta = 0.115; #elasticity of labor
R = 3.131696599;
chi = 0.5;
M = log(1056);
sigma = 1.336449027; #degree of product substitutability
W = log(29448.08908);
P = 3.0686;
aval = 1.25;
c = 0.5;
f = function(b){
loutpow = sigma/(beta*(sigma-1)-sigma);
lconst1 = sigma/(beta*(sigma-1));
lconst2 = (aval*kval^alpha)^((1 - sigma)/sigma);
lconst3 = (R*P^(sigma-1))^(1/sigma);
lval = (W/b*lconst2/lconst3*lconst1)^loutpow;
profit_first_term = (R*P^(sigma-1))^(1/sigma)*(aval*kval^alpha*lval^beta)^(1-(1/sigma));
profit_middle_terms = kval - kprimeval - f_t*kprimeval - c(kval - kprimeval)^2
profit_last_term = W/b*lval
profit = profit_first_term + profit_middle_terms - profit_last_term
bankruptcy = profit - chi*dval
}
For a range of kval,kprimeval,dval from 1 to 10000, I want to find the roots of this equation, that is the value of b. It is possible that for some values of kval,kprimeval,dval roots do not exist.
apparently your function has not a zero:
curve(f(x), -1, 1e9)
I am trying to perform differential gene expression using a t-test on spatial RNA-sequencing data. There are a couple of different annotations/groups indicating different structures (ANN2 in code): AML area, Taggregate, immatureTLS, matureTLS, and microcluster. ANN1 relates to one of the 3 different patients.
The error I get:
Error in h(simpleError(msg, call)) :
error in evaluating the argument 'x' in selecting a method for function 'as.data.frame': not enough 'y' observations
I don’t understand how my data has not enough y-observations, and how I could overcome this error. I have searched google and other blogs, but I wasn’t able to resolve it.
The code I use (all the code I used before is shown on this website: https://bioconductor.org/packages/devel/workflows/vignettes/GeoMxWorkflows/inst/doc/GeomxTools_RNA-NGS_Analysis.html )
7.1 Differential Expression
plots<-list()
tables<-list()
labels<-list()
test<-"ttest"
mtc<-"BY"
#options: "holm" "hochberg" "hommel" "bonferroni" "BH" "BY" "fdr"
counter=1
comps_df<-data.frame(comp='',val='')
for (active_group1 in unique(ann$segment)) {
for (active_group2 in unique(ann$segment)) {
#supress reduncant compares
if(active_group1==active_group2) {next}
comp<-paste(sort(c(active_group1,active_group2)),collapse = "_")
if(comp %in% comps_df$comp) {next}
temp_df<-data.frame(comp=comp ,val=1)
comps_df<-rbind(comps_df,temp_df)
labels[[counter]]<-paste(active_group1," vs ", active_group2)
group1<-log_q[,rownames(ann)[ann$segment==active_group1]]
group2<-log_q[,rownames(ann)[ann$segment==active_group2]]
#run t_tests
results<-as.data.frame ( apply(log_q, 1, function(x) t.test(x[colnames(group1)],x[colnames(group2)])$p.value) )
colnames(results)<-"raw_p_value"
#multiple_testing_correction
adj_p_value<- p.adjust(results$raw_p_value,method=mtc)
results<-cbind(results,adj_p_value)
#calc_fdr
FDR<- p.adjust(results$raw_p_value,method="fdr")
results<-cbind(results,FDR)
#fold_changes
#as base data is already log transformed, means need to be subtracted to get FC in log space
fchanges<-as.data.frame( apply(log_q, 1, function(x) (mean(x[colnames(group1)]) - mean(x[colnames(group2)]) ) ) )
colnames(fchanges)<-"FC"
#paste("FC",active_group1," / ",active_group2)
results<-cbind(results,fchanges)
#add genenames
results$Gene<-rownames(results)
#set categories based on P-value & FDR for plotting
results$Color <- "NS or FC < 0.5"
results$Color[results$adj_p_value < 0.05] <- "P < 0.05"
results$Color[results$FDR < 0.05] <- "FDR < 0.05"
results$Color[results$FDR < 0.001] <- "FDR < 0.001"
results$Color[abs(results$FC) < 1] <- "NS or FC < 1"
results$Color <- factor(results$Color,
levels = c("NS or FC < 1", "P < 0.05", "FDR < 0.05", "FDR < 0.001"))
#vulcanoplot
# pick top genes for either side of volcano to label
# order genes for convenience:
results$invert_P <- (-log10(results$adj_p_value)) * sign(results$FC)
top_g <- c()
top_g <- c(top_g,
results[ind, 'Gene'][
order(results[ind, 'invert_P'], decreasing = TRUE)[1:15]],
results[ind, 'Gene'][order(results[ind, 'invert_P'], decreasing = FALSE)[1:15]])
top_g<- unique(top_g)
results <- results[, -1*ncol(results)] # remove invert_P from matrix
# Graph results
plots[[counter]]<- ggplot(results,
aes(x = FC, y = -log10(adj_p_value),
color = Color, label = Gene)) +
geom_vline(xintercept = c(1, -1), lty = "dashed") +
geom_hline(yintercept = -log10(0.05), lty = "dashed") +
geom_point() +
labs(x = paste("Enriched in", active_group2," <- log2(FC) -> Enriched in", active_group1),
y = "Significance, -log10(P)",
color = "Significance") +
scale_color_manual(values = c(`FDR < 0.001` = "dodgerblue",
`FDR < 0.05` = "lightblue",
`P < 0.05` = "orange2",
`NS or FC < 0.5` = "gray"),
guide = guide_legend(override.aes = list(size = 4))) +
scale_y_continuous(expand = expansion(mult = c(0,0.05))) +
geom_text_repel(data = subset(results, FDR<0.001 & (-1>FC| FC>1)),
point.padding = 0.15, color = "black", size=3.5,
min.segment.length = .1, box.padding = .2, lwd = 2,
max.overlaps = 50) +
theme_bw(base_size = 20) +
theme(legend.position = "bottom") +
ggtitle(paste(test, mtc,"multitest corr"))
#store tables for display later
tables[[counter]]<-results
counter = counter+1
#datatable(subset(results, Gene %in% GOI), rownames=FALSE,caption = paste("DE results ", active_group1," vs ", active_group2))
}
}
grid.arrange(grobs=plots,ncol=2)
#strangly does not appear in html output??
for (c in (2:counter-1)) {
#Gene %in% GOI
print(datatable( subset(tables[[c]], Color == "FDR < 0.001" ),
rownames=FALSE,
extensions = 'Buttons', options = list (
dom = 'Bftrip',
buttons = c('copy', 'csv', 'excel', 'pdf', 'print')
),
caption = paste("DE results ", labels[[1]]),filter='top') %>% formatRound(columns=c("raw_p_value","adj_p_value","FDR","FC"), digits=3))
cat('\n\n<!-- -->\n\n')
}
[normalised data example][1]Data type which is used as input:
[1]: https://i.stack.imgur.com/Yt0DJ.png
Any help would be greatly appreciated! Thanks
I am trying to create a forestplot, using forestplotter function, am able to get a beautiful graph, but am not able to see the entire graph, the column widths in few of the columns are so big, even if the string size is less, making the width of the entire graph, so big to see, can someone help me with this and also is it possible to align the datahrame contents uniformly centre aligned......Please help me with this
The code and relevant data are
###Required packages###
library(grid)
library(forestploter)
library(rmeta)
library(gridExtra)
#Data entered#
df <- data.frame(Study=c("A","B","C","D","Summary"),
nA = c(24,187,36,26,273),
median_A = c(4.9,5.69,8.866995074,8.5,NA),
Q1A =c(3,2.86,4.495073892,2,NA),
Q3A =c(8.5,9.78,14.96305419,32,NA),
nP = c(23,193,36,26,278),
median_P = c(7.2,6.79,8.990147783,12.5,NA),
Q1P =c(3.4,3.59,4.002463054,2,NA),
Q3P =c(10.9,10.12,12.06896552,43,NA),
W = c("10.6%","80.8%","8.0%","0.70%",NA),
E=c(-2.3,-1.1,-0.123152709,-4,-1.16881587),
UL=c(1.161473203,0.156288294,3.881699516,10.02689306,-0.039791047),
LL=c(-5.761473203,-2.356288294,-4.128004935,-18.02689306,-2.297840692))
#Calculate SE for box size#
df$SE <- (df$UL-df$E)/1.96
#Column for Confidence intervals for Drug A and Placebo, with 2 significant digit#
df$IQRA <- sprintf("%.2f (%.2f to %.2f)",df$median_A,df$Q1A, df$Q3A)
df$IQRP <- sprintf("%.2f (%.2f to %.2f)",df$median_P,df$Q1P, df$Q3P)
#Column for Confidence intervals for NET EFFECT, with 2 significant digit#
df$MD <- sprintf("%.2f (%.2f to %.2f)", df$E, df$LL, df$UL)
#Create a column with space for forest plot#
df$" "<- paste(rep(" ", 16), collapse = " ")
##Forest plot theme##
#To be modified as needed#
ftn <-forest_theme(
base_size = 16,
base_family = "serif",
ci_pch = 15,
ci_col = "black",
ci_lty = 1,
ci_lwd = 1,
ci_Theight = 0.25,
legend_name = " ",
legend_position = "right",legend_value = "",
xaxis_lwd = 1,
xaxis_cex = 0.7,
refline_lwd = 1,
refline_lty = "dashed",
refline_col = "red",
summary_fill = "blue",
summary_col = "blue",
footnote_cex = 0.4,
footnote_fontface = "plain",
footnote_col = "black",
title_just = c("center"),
title_cex = 1.1,
title_fontface = "bold",
title_col = "black",
show.rownames = FALSE)
##Table in Order for Forest plot##
#First get Column names#
colnames(df)
df2 <-df[,c(1,2,15,6,16,18,17)]
#Make NA cells empty
df2[5,3] <-c(" ")
df2[5,5] <-c(" ")
##Forestplot##
plot<-forest(df2,
est = df$E,
lower = df$LL,
upper = df$UL,
sizes = (df$SE/10),
ci_column = 6,
ref_line = 0,
arrow_lab = c("Drug A Better", "Placebo Better"),
xlim = c(-7, 6),
is_summary = c(FALSE,FALSE,FALSE,FALSE,TRUE),
xlog = FALSE,
ticks_digits = 0,ticks_at = c(-6,0,6),
theme = ftn)
##Show plot
print(plot, autofit = FALSE)
I want to create major and minor ticks in my date-formatted x-axis, so that for every 3rd tick (representing every 3 months) I have a major tick and a label.
This is a reproducible example of what I have so far, which currently has uniform ticks.
month<-c("2010-08-01", "2010-09-01", "2010-10-01", "2010-12-01", "2011-01-01", "2011-02-01",
"2011-03-01", "2011-04-01", "2011-05-01", "2011-06-01", "2011-07-01", "2011-09-01",
"2011-11-01", "2012-01-01", "2012-02-01", "2012-03-01", "2012-05-01", "2012-07-01",
"2012-08-01")
prevalence<-c(10,7.5,5.2,3.5,6.4,2.7,5.8,13.2,4.3,4.7,6.4,4.4,5.2,3.3,1.0,3.1,9.9,33.3,1.0)
df<-data.frame(month, prevalence)
df$month<-as.Date(df$month)
plot(df$month, df$prevalence,lwd = 1.8, ylim=c(0,40),pch=16, bty='n', xaxt='n',
ylab="Prevalence (%)", xlab="Month",col='black',cex=1,cex.lab=1.0,cex.axis=1.0)
at <- seq(from = min(df$month), to = max(df$month), by = "month") # produces a regular sequence of dates
axis.Date(side = 1, at = at, labels = FALSE, tck=-0.04)
axis(side=2, at=c(0,10,20,30,40,50), labels=c("", "", "", "", "", ""), tck=-0.04)
lines(df$month, df$prevalence, col='black', lwd=1.8)
I have tried using the package magicaxis, but it does not seem to allow for date-formatted axes.
As a quick fix you could use repeat axis.Date calls.
at1 <- at[c(TRUE, TRUE, FALSE)]
axis.Date(side = 1, at = at1, labels = FALSE, tck=-0.02)
at2 <- at[c(FALSE, FALSE, TRUE)]
axis.Date(side = 1, at = at2, labels = TRUE, tck=-0.04)
The TRUE and FALSE are used to subset the vector at
I don't know if this is still a problem for someone, but I made a general purpose function for axes with minor ticks, based on the base axis() function, and with similar arguments. It's available in the StratigrapheR package under minorAxis()
minorAxis <- function(side, n = NULL, at.maj = NULL, at.min = NULL, range = NULL,
tick.ratio = 0.5, labels.maj = TRUE, line = NA, pos = NA,
outer = FALSE, font = NA, lty = "solid", lwd = 1,
lwd.ticks = lwd, col = NULL, col.ticks = NULL, hadj = NA,
padj = NA, extend = FALSE, tcl = NA, ...)
{
if(side == 1 | side == 3){
tick.pos <- par("xaxp")
} else if (side == 2 | side == 4) {
tick.pos <- par("yaxp")
}
# Define the positions of major ticks ----
if(is.null(at.maj)) {
# nat.int <- (tick.pos[2] - tick.pos[1])/tick.pos[3]
at.maj <- seq(tick.pos[1], tick.pos[2],
by = (tick.pos[2] - tick.pos[1])/tick.pos[3])
}
# Define range, exclude at.maj values if necessary ----
if(length(range) != 0){
eff.range <- range
r1 <- at.maj - min(range)
r2 <- at.maj - max(range)
p1 <- which.min(abs(r1))
p2 <- which.min(abs(r2))
if(!(abs(r1[p1]/min(range)) < 1.5e-8) & r1[p1] < 0) p1 <- p1 + 1
if(!(abs(r2[p2]/max(range)) < 1.5e-8) & r2[p2] > 0) p2 <- p2 - 1
at.maj <- at.maj[p1:p2]
} else {
if(side == 1 | side == 3){
eff.range <- par("usr")[1:2]
} else if (side == 2 | side == 4) {
eff.range <- par("usr")[3:4]
}
}
# Define limits ----
if(!extend) {
if(!is.null(at.min) & length(range) == 0){
limits <- c(min(c(at.min, at.maj)), max(c(at.min, at.maj)))
} else {
limits <- c(min(at.maj), max(at.maj))
}
} else {
limits <- eff.range
}
# Standard axis when n and at.min are not given ----
if(is.null(n) & is.null(at.min)){
axis(side, at = limits, labels = FALSE, tick = TRUE, line = line,
pos = pos, outer = outer, lty = lty, lwd = lwd, lwd.ticks = 0,
col = col,...)
axis(side, at = at.maj, labels = labels.maj, tick = TRUE, line = line,
pos = pos, outer = outer, font = font, lty = lty,
lwd = 0, lwd.ticks = lwd.ticks, col = col, col.ticks = col.ticks,
hadj = hadj, padj = padj, tcl = tcl,...)
} else {
# Work the minor ticks: check regularity ----
mina <- min(at.maj)
maxa <- max(at.maj)
difa <- maxa - mina
na <- difa / (length(at.maj) - 1)
if(is.null(at.min))
{
# n realm ----
# Checks----
sia <- seq(mina,maxa,by = na)
if(!isTRUE(all.equal(sort(sia),sort(at.maj)))) {
stop("at.maj is irregular, use at.min for minor ticks (not n)")
}
if(!(is.numeric(n) & length(n) == 1)){
stop("n should be a numeric of length one")
}
# Work it ----
tick.pos <- c(mina,maxa,difa/na)
nat.int <- (tick.pos[2] - tick.pos[1])/tick.pos[3]
# Define the position of minor ticks ----
distance.between.minor <- nat.int/n
p <- seq(min(at.maj), max(at.maj), by = distance.between.minor)
q <- sort(every_nth(p,n,empty=FALSE))
# Extend outside of major ticks range if necessary ----
if(!extend) {
tick.seq <- q
} else {
possible.low.minors <- min(at.maj) - (n:1) * distance.between.minor
possible.hi.minors <- max(at.maj) + (1:n) * distance.between.minor
r3 <- possible.low.minors - min(eff.range)
r4 <- possible.hi.minors - max(eff.range)
p3 <- which.min(abs(r3))
p4 <- which.min(abs(r4))
if(!(abs(r3[p3]/min(eff.range)) < 1.5e-8) & r3[p3] < 0) p3 <- p3 + 1
if(!(abs(r4[p4]/max(eff.range)) < 1.5e-8) & r4[p4] > 0) p4 <- p4 - 1
if(p3 < length(possible.low.minors + 1)){
low.candidates <- seq(p3, length(possible.low.minors), 1)
low.laureates <- possible.low.minors[low.candidates]
} else {
low.laureates <- NULL
}
if(p4 > 0){
hi.candidates <- seq(1, p4, 1)
hi.laureates <- possible.hi.minors[ hi.candidates]
} else {
hi.laureates <- NULL
}
tick.seq <- c(low.laureates,q,hi.laureates)
}
} else {
# at.min realm ----
tick.pos <- c(mina,maxa,na)
tick.seq <- sort(at.min)
if(length(range) != 0){
r3 <- tick.seq - min(eff.range)
r4 <- tick.seq - max(eff.range)
p3 <- which.min(abs(r3))
p4 <- which.min(abs(r4))
if(!(abs(r3[p3]/min(eff.range)) < 1.5e-8) & r3[p3] < 0) p3 <- p3 + 1
if(!(abs(r4[p4]/max(eff.range)) < 1.5e-8) & r4[p4] > 0) p4 <- p4 - 1
tick.seq <- tick.seq [p3:p4]
}
}
# Define the length of ticks ----
if(is.na(tcl)) maj.tcl <- par()$tcl else if (!is.na(tcl)) maj.tcl <- tcl
min.tcl <- maj.tcl*tick.ratio
# Plot the axes ----
axis(side, at = limits, labels = FALSE, tick = TRUE, line = line,
pos = pos, outer = outer, lty = lty, lwd = lwd, lwd.ticks = 0,
col = col,...)
axis(side, at = at.maj, labels = labels.maj, tick = TRUE, line = line,
pos = pos, outer = outer, font = font, lty = lty,
lwd = 0, lwd.ticks = lwd.ticks, col = col, col.ticks = col.ticks,
hadj = hadj, padj = padj, tcl = maj.tcl,...)
axis(side, at = tick.seq, labels = FALSE, tick = TRUE, line = line,
pos = pos, outer = outer, lwd = 0, lwd.ticks = lwd.ticks, col = col,
col.ticks = col.ticks, tcl = min.tcl,...)
}
}
# Run this as example:
plot(c(0,1), c(0,1), axes = FALSE, type = "n", xlab = "", ylab = "")
minorAxis(1, n = 10, range = c(0.12,0.61))
minorAxis(3, n = 10, extend=FALSE)
How can I draw the following plot in R?
Red = 30
Yellow = 40
Green = 30
Needle at 52.
So here's a fully ggplot solution.
Note: Edited from the original post to add numeric indicator and labels at the gauge breaks which seems to be what OP is asking for in their comment. If indicator is not needed, remove the annotate(...) line. If labels are not needed, remove geom_text(...) line.
gg.gauge <- function(pos,breaks=c(0,30,70,100)) {
require(ggplot2)
get.poly <- function(a,b,r1=0.5,r2=1.0) {
th.start <- pi*(1-a/100)
th.end <- pi*(1-b/100)
th <- seq(th.start,th.end,length=100)
x <- c(r1*cos(th),rev(r2*cos(th)))
y <- c(r1*sin(th),rev(r2*sin(th)))
return(data.frame(x,y))
}
ggplot()+
geom_polygon(data=get.poly(breaks[1],breaks[2]),aes(x,y),fill="red")+
geom_polygon(data=get.poly(breaks[2],breaks[3]),aes(x,y),fill="gold")+
geom_polygon(data=get.poly(breaks[3],breaks[4]),aes(x,y),fill="forestgreen")+
geom_polygon(data=get.poly(pos-1,pos+1,0.2),aes(x,y))+
geom_text(data=as.data.frame(breaks), size=5, fontface="bold", vjust=0,
aes(x=1.1*cos(pi*(1-breaks/100)),y=1.1*sin(pi*(1-breaks/100)),label=paste0(breaks,"%")))+
annotate("text",x=0,y=0,label=pos,vjust=0,size=8,fontface="bold")+
coord_fixed()+
theme_bw()+
theme(axis.text=element_blank(),
axis.title=element_blank(),
axis.ticks=element_blank(),
panel.grid=element_blank(),
panel.border=element_blank())
}
gg.gauge(52,breaks=c(0,35,70,100))
## multiple guages
library(gridExtra)
grid.newpage()
grid.draw(arrangeGrob(gg.gauge(10),gg.gauge(20),
gg.gauge(52),gg.gauge(90),ncol=2))
You will likely need to tweak the size=... parameter to geom_text(...) and annotate(...) depending on the actual size of your gauge.
IMO the segment labels are a really bad idea: they clutter the image and defeat the purpose of the graphic (to indicate at a glance if the metric is in "safe", "warning", or "danger" territory).
Here's a very quick and dirty implementation using grid graphics
library(grid)
draw.gauge<-function(x, from=0, to=100, breaks=3,
label=NULL, axis=TRUE, cols=c("red","yellow","green")) {
if (length(breaks)==1) {
breaks <- seq(0, 1, length.out=breaks+1)
} else {
breaks <- (breaks-from)/(to-from)
}
stopifnot(length(breaks) == (length(cols)+1))
arch<-function(theta.start, theta.end, r1=1, r2=.5, col="grey", n=100) {
t<-seq(theta.start, theta.end, length.out=n)
t<-(1-t)*pi
x<-c(r1*cos(t), r2*cos(rev(t)))
y<-c(r1*sin(t), r2*sin(rev(t)))
grid.polygon(x,y, default.units="native", gp=gpar(fill=col))
}
tick<-function(theta, r, w=.01) {
t<-(1-theta)*pi
x<-c(r*cos(t-w), r*cos(t+w), 0)
y<-c(r*sin(t-w), r*sin(t+w), 0)
grid.polygon(x,y, default.units="native", gp=gpar(fill="grey"))
}
addlabel<-function(m, theta, r) {
t<-(1-theta)*pi
x<-r*cos(t)
y<-r*sin(t)
grid.text(m,x,y, default.units="native")
}
pushViewport(viewport(w=.8, h=.40, xscale=c(-1,1), yscale=c(0,1)))
bp <- split(t(embed(breaks, 2)), 1:2)
do.call(Map, list(arch, theta.start=bp[[1]],theta.end=bp[[2]], col=cols))
p<-(x-from)/(to-from)
if (!is.null(axis)) {
if(is.logical(axis) && axis) {
m <- round(breaks*(to-from)+from,0)
} else if (is.function(axis)) {
m <- axis(breaks, from, to)
} else if(is.character(axis)) {
m <- axis
} else {
m <- character(0)
}
if(length(m)>0) addlabel(m, breaks, 1.10)
}
tick(p, 1.03)
if(!is.null(label)) {
if(is.logical(label) && label) {
m <- x
} else if (is.function(label)) {
m <- label(x)
} else {
m <- label
}
addlabel(m, p, 1.15)
}
upViewport()
}
This function can be used to draw one gauge
grid.newpage()
draw.gauge(100*runif(1))
or many gauges
grid.newpage()
pushViewport(viewport(layout=grid.layout(2,2)))
for(i in 1:4) {
pushViewport(viewport(layout.pos.col=(i-1) %/%2 +1, layout.pos.row=(i-1) %% 2 + 1))
draw.gauge(100*runif(1))
upViewport()
}
popViewport()
It's not too fancy so it should be easy to customize.
You can now also add a label
draw.gauge(75, label="75%")
I've added another update to allow for drawing an "axis". You can set it to TRUE to use default values, or you can pass in a character vector to give whatever labels you want, or you can pass in a function that will take the breaks (scaled 0-1) and the from/to values and should return a character value.
grid.newpage()
draw.gauge(100*runif(1), breaks=c(0,30,70,100), axis=T)
Flexdashboard has a simple function for guage chart. For details take a look at https://rdrr.io/cran/flexdashboard/man/gauge.html
You can plot the chart using a simple call like:
gauge(42, min = 0, max = 100, symbol = '%',
gaugeSectors(success = c(80, 100), warning = c(40, 79), danger = c(0, 39)))
I found this solution from Gaston Sanchez's blog:
library(googleVis)
plot(gvisGauge(data.frame(Label=”UserR!”, Value=80),
options=list(min=0, max=100,
yellowFrom=80, yellowTo=90,
redFrom=90, redTo=100)))
Here is the function created later:
# Original code by Gaston Sanchez http://www.r-bloggers.com/gauge-chart-in-r/
#
dial.plot <- function(label = "UseR!", value = 78, dial.radius = 1
, value.cex = 3, value.color = "black"
, label.cex = 3, label.color = "black"
, gage.bg.color = "white"
, yellowFrom = 75, yellowTo = 90, yellow.slice.color = "#FF9900"
, redFrom = 90, redTo = 100, red.slice.color = "#DC3912"
, needle.color = "red", needle.center.color = "black", needle.center.cex = 1
, dial.digets.color = "grey50"
, heavy.border.color = "gray85", thin.border.color = "gray20", minor.ticks.color = "gray55", major.ticks.color = "gray45") {
whiteFrom = min(yellowFrom, redFrom) - 2
whiteTo = max(yellowTo, redTo) + 2
# function to create a circle
circle <- function(center=c(0,0), radius=1, npoints=100)
{
r = radius
tt = seq(0, 2*pi, length=npoints)
xx = center[1] + r * cos(tt)
yy = center[1] + r * sin(tt)
return(data.frame(x = xx, y = yy))
}
# function to get slices
slice2xy <- function(t, rad)
{
t2p = -1 * t * pi + 10*pi/8
list(x = rad * cos(t2p), y = rad * sin(t2p))
}
# function to get major and minor tick marks
ticks <- function(center=c(0,0), from=0, to=2*pi, radius=0.9, npoints=5)
{
r = radius
tt = seq(from, to, length=npoints)
xx = center[1] + r * cos(tt)
yy = center[1] + r * sin(tt)
return(data.frame(x = xx, y = yy))
}
# external circle (this will be used for the black border)
border_cir = circle(c(0,0), radius=dial.radius, npoints = 100)
# open plot
plot(border_cir$x, border_cir$y, type="n", asp=1, axes=FALSE,
xlim=c(-1.05,1.05), ylim=c(-1.05,1.05),
xlab="", ylab="")
# gray border circle
external_cir = circle(c(0,0), radius=( dial.radius * 0.97 ), npoints = 100)
# initial gage background
polygon(external_cir$x, external_cir$y,
border = gage.bg.color, col = gage.bg.color, lty = NULL)
# add gray border
lines(external_cir$x, external_cir$y, col=heavy.border.color, lwd=18)
# add external border
lines(border_cir$x, border_cir$y, col=thin.border.color, lwd=2)
# yellow slice (this will be used for the yellow band)
yel_ini = (yellowFrom/100) * (12/8)
yel_fin = (yellowTo/100) * (12/8)
Syel = slice2xy(seq.int(yel_ini, yel_fin, length.out = 30), rad= (dial.radius * 0.9) )
polygon(c(Syel$x, 0), c(Syel$y, 0),
border = yellow.slice.color, col = yellow.slice.color, lty = NULL)
# red slice (this will be used for the red band)
red_ini = (redFrom/100) * (12/8)
red_fin = (redTo/100) * (12/8)
Sred = slice2xy(seq.int(red_ini, red_fin, length.out = 30), rad= (dial.radius * 0.9) )
polygon(c(Sred$x, 0), c(Sred$y, 0),
border = red.slice.color, col = red.slice.color, lty = NULL)
# white slice (this will be used to get the yellow and red bands)
white_ini = (whiteFrom/100) * (12/8)
white_fin = (whiteTo/100) * (12/8)
Swhi = slice2xy(seq.int(white_ini, white_fin, length.out = 30), rad= (dial.radius * 0.8) )
polygon(c(Swhi$x, 0), c(Swhi$y, 0),
border = gage.bg.color, col = gage.bg.color, lty = NULL)
# calc and plot minor ticks
minor.tix.out <- ticks(c(0,0), from=5*pi/4, to=-pi/4, radius=( dial.radius * 0.89 ), 21)
minor.tix.in <- ticks(c(0,0), from=5*pi/4, to=-pi/4, radius=( dial.radius * 0.85 ), 21)
arrows(x0=minor.tix.out$x, y0=minor.tix.out$y, x1=minor.tix.in$x, y1=minor.tix.in$y,
length=0, lwd=2.5, col=minor.ticks.color)
# coordinates of major ticks (will be plotted as arrows)
major_ticks_out = ticks(c(0,0), from=5*pi/4, to=-pi/4, radius=( dial.radius * 0.9 ), 5)
major_ticks_in = ticks(c(0,0), from=5*pi/4, to=-pi/4, radius=( dial.radius * 0.77 ), 5)
arrows(x0=major_ticks_out$x, y0=major_ticks_out$y, col=major.ticks.color,
x1=major_ticks_in$x, y1=major_ticks_in$y, length=0, lwd=3)
# calc and plot numbers at major ticks
dial.numbers <- ticks(c(0,0), from=5*pi/4, to=-pi/4, radius=( dial.radius * 0.70 ), 5)
dial.lables <- c("0", "25", "50", "75", "100")
text(dial.numbers$x, dial.numbers$y, labels=dial.lables, col=dial.digets.color, cex=.8)
# Add dial lables
text(0, (dial.radius * -0.65), value, cex=value.cex, col=value.color)
# add label of variable
text(0, (dial.radius * 0.43), label, cex=label.cex, col=label.color)
# add needle
# angle of needle pointing to the specified value
val = (value/100) * (12/8)
v = -1 * val * pi + 10*pi/8 # 10/8 becuase we are drawing on only %80 of the cir
# x-y coordinates of needle
needle.length <- dial.radius * .67
needle.end.x = needle.length * cos(v)
needle.end.y = needle.length * sin(v)
needle.short.length <- dial.radius * .1
needle.short.end.x = needle.short.length * -cos(v)
needle.short.end.y = needle.short.length * -sin(v)
needle.side.length <- dial.radius * .05
needle.side1.end.x = needle.side.length * cos(v - pi/2)
needle.side1.end.y = needle.side.length * sin(v - pi/2)
needle.side2.end.x = needle.side.length * cos(v + pi/2)
needle.side2.end.y = needle.side.length * sin(v + pi/2)
needle.x.points <- c(needle.end.x, needle.side1.end.x, needle.short.end.x, needle.side2.end.x)
needle.y.points <- c(needle.end.y, needle.side1.end.y, needle.short.end.y, needle.side2.end.y)
polygon(needle.x.points, needle.y.points, col=needle.color)
# add central blue point
points(0, 0, col=needle.center.color, pch=20, cex=needle.center.cex)
# add values 0 and 100
}
par(mar=c(0.2,0.2,0.2,0.2), bg="black", mfrow=c(2,2))
dial.plot ()
dial.plot (label = "Working", value = 25, dial.radius = 1
, value.cex = 3.3, value.color = "white"
, label.cex = 2.7, label.color = "white"
, gage.bg.color = "black"
, yellowFrom = 73, yellowTo = 95, yellow.slice.color = "gold"
, redFrom = 95, redTo = 100, red.slice.color = "red"
, needle.color = "red", needle.center.color = "white", needle.center.cex = 1
, dial.digets.color = "white"
, heavy.border.color = "white", thin.border.color = "black", minor.ticks.color = "white", major.ticks.color = "white")
dial.plot (label = "caffeine", value = 63, dial.radius = .7
, value.cex = 2.3, value.color = "white"
, label.cex = 1.7, label.color = "white"
, gage.bg.color = "black"
, yellowFrom = 80, yellowTo = 93, yellow.slice.color = "gold"
, redFrom = 93, redTo = 100, red.slice.color = "red"
, needle.color = "red", needle.center.color = "white", needle.center.cex = 1
, dial.digets.color = "white"
, heavy.border.color = "black", thin.border.color = "lightsteelblue4", minor.ticks.color = "orange", major.ticks.color = "tan")
dial.plot (label = "Fun", value = 83, dial.radius = .7
, value.cex = 2.3, value.color = "white"
, label.cex = 1.7, label.color = "white"
, gage.bg.color = "black"
, yellowFrom = 20, yellowTo = 75, yellow.slice.color = "olivedrab"
, redFrom = 75, redTo = 100, red.slice.color = "green"
, needle.color = "red", needle.center.color = "white", needle.center.cex = 1
, dial.digets.color = "white"
, heavy.border.color = "black", thin.border.color = "lightsteelblue4", minor.ticks.color = "orange", major.ticks.color = "tan")