Changing one word in character string to bold face using textplot() - r

I'm using textplot() from the gplots package to write definitions that are then displayed next to other plots using par(mfrow=c(3,2)).
I want to change a single word in the character string to bold face (Usually the word being defined). Is there a metacharacter that will let me do this inside of the " "? Or another solution for picking out words and giving them bold attributes without assigning that to the whole string?
It's similar to this question, but I wasn't able to use the same technique in textplot():
text() R-function - how to change the font of a single word?
text(0.5,0.5, expression(paste(bold("bold")," not bold")))
Here's my code without a bolded term. Pretend "Definition" is desired to be bold face:
blurb<-strwrap("Definition: This is my text blurb",
width=60)
textplot(blurb, halign="left", valign="top", cex = 1, family="serif")
I've been playing with breaking the string apart and searching for a function that will assign bold face to the "Definition" portion, font=2, and then pasting the string back together, but I'm stumped. I can't find a function to use:
blurb1<-"Definition" ##How to change to bold face??
blurb2<-"This is my text blurb"
blurb<-paste0(blurb1,blurb2)
EDIT: The predominant barrier to using other solutions is that for my page layout, text() isn't entirely viable. I'm hoping to find a solution to editing the string either inside of textplot() or in a way that can be passed to textplot().
I'm creating something of a "Report Card" that will plot user data and provide a paragraph of explanation beside the plot. Different values would trigger a different textplot(). I like textplot() because it's easily placed with par(mfrow=c(4,2)), carving out a seperate space without overlapping other plots. I just can't seem to work text() in without a lot of play in the positioning.

You need to use bquote().
Here is a simple function which takes a text string and splits it and returns the appropriate expression for your bold plotting needs. I am sure you can adapt this as you see fit.
# Pass the function a string and a character to split on
# The splitting is greedy (i.e. it will split on all matches so make sure you are splitting on a unqiue character such as ":" in your example)
tsplit <- function( string , split ){
require( stringr )
blurb <- paste( string )
blurbs <- strsplit( blurb , paste(split) )
annot <- bquote( paste( bold( .( blurbs[[1]][1] ) ) , .(split) , .(blurbs[[1]][2]) , sep = "" ) )
return( annot )
}
#And the function in action...
j <- tsplit( "Define: This is my blurb" , ":" )
textplot( paste( " " ) ) #Get new plot
text(0.5 , 0.5 , j ) #paste the text
I hope this helps. The function assumes that there is only one unique character to split the string on and that you want the first word in bold and the rest of the string in normal format.
Cheers
EDIT
Sorry I realised in the question you said you couldn't use text for placement because it is problematic. A quick check of the available methods of textplot (showMethods(textplot)) and the source of the apporopriate method for plotting characters (getAnywhere(textplot.character)) shows that textplot does infact use a call to text to annotate the plot with your text object. Most of the code is concerned with taking out the heavy lifting of where you want the text. You can make a couple of simple adjustments to textplot.character() to create a custom function to do what you wanted. You can copy and paste this into R and it should work as per the example at the bottom.
tplot.cust <- function ( object , split , halign = c("center", "left", "right"), valign = c("center",
"top", "bottom"), cex, fixed.width = TRUE, cspace = 1, lspace = 1,
mar = c(0, 0, 3, 0) + 0.1, tab.width = 8, ...)
{
# extra code to split text according to 'split' argument and make text before the split bold.
require(stringr)
blurb <- paste( object )
blurbs <- strsplit( blurb , paste(split) )
annot <- bquote( paste( bold( .( blurbs[[1]][1] ) ) , .(split) , .(blurbs[[1]][2]) , sep = "" ) )
object <- paste(object, collapse = "\n", sep = "")
object <- gplots:::replaceTabs(object, width = tab.width) #you need to add gplots::: to this line because replaceTabs is a function that is not exported from the gplots namespace
halign = match.arg(halign)
valign = match.arg(valign)
plot.new()
opar <- par()[c("mar", "xpd", "cex", "family")]
on.exit(par(opar))
par(mar = mar, xpd = FALSE)
if (fixed.width)
par(family = "mono")
plot.window(xlim = c(0, 1), ylim = c(0, 1), log = "", asp = NA)
slist <- unlist(lapply(object, function(x) strsplit(x, "\n")))
slist <- lapply(slist, function(x) unlist(strsplit(x, "")))
slen <- sapply(slist, length)
slines <- length(slist)
if (missing(cex)) {
lastloop <- FALSE
cex <- 1
}
else lastloop <- TRUE
for (i in 1:20) {
oldcex <- cex
cwidth <- max(sapply(unlist(slist), strwidth, cex = cex)) *
cspace
cheight <- max(sapply(unlist(slist), strheight, cex = cex)) *
(lspace + 0.5)
width <- strwidth(object, cex = cex)
height <- strheight(object, cex = cex)
if (lastloop)
break
cex <- cex/max(width, height)
if (abs(oldcex - cex) < 0.001) {
lastloop <- TRUE
}
}
if (halign == "left")
xpos <- 0
else if (halign == "center")
xpos <- 0 + (1 - width)/2
else xpos <- 0 + (1 - width)
if (valign == "top")
ypos <- 1
else if (valign == "center")
ypos <- 1 - (1 - height)/2
else ypos <- 1 - (1 - height)
text(x = xpos, y = ypos, labels = annot , adj = c(0, 1),
cex = cex, ...) #add the newly created annot expression here
par(opar)
invisible(cex)
}
We can then use tplot.cust like so...
blurb <- "Define: This is my blurb"
tplot.cust(blurb, ":" , halign="left", valign="top", cex = 1, family="serif")
Hopefully this is what you want??

Related

Question about the functions `get_test_label` and `get_pwc_label` from the `rstatix` package

I have recently become familiar with the rstatix package. Below is an example code using functions from this package.
library(tidyverse)
library(rstatix)
library(ggpubr)
set.seed(1111)
n=100
df = tibble(
x1 = rnorm(n, 0, 1.1),
x2 = rnorm(n, 0.2, .1),
x3 = rnorm(n, -.2, .2),
x4 = rnorm(n, 0, 2),
) %>% pivot_longer(x1:x4)
df
pwc = df %>%
pairwise_t_test(value~name, paired = TRUE,
p.adjust.method = "bonferroni") %>%
add_xy_position(x = "name") %>%
mutate(name=group1,
lab = paste(p, " - ", p.adj.signif))
res.test = df %>% anova_test(value~name)
df %>% ggplot(aes(name, value))+
geom_boxplot(alpha=0.6)+
stat_pvalue_manual(pwc, step.increase=0.05, label = "lab")+
labs(title = get_test_label(res.test, detailed = TRUE),
subtitle = get_pwc_label(pwc))
However, I noticed that functions like get_test_label or get_pwc_label do not return text, but commands to prepare the text.
For example, calling get_test_label(res.test, detailed = TRUE) gives this:
paste("Anova, ", italic("F"), "(3,396)", " = ",
"5.26, ", italic("p"), " = ", "0.001",
paste(", ", eta["g"]^2, " = ", 0.04), "")
In turn, calling get_pwc_label(pwc) will result in:
paste("pwc: ", bold(c(t_test = "T test")), "; p.adjust: ",
bold("Bonferroni"))
Now my question, basically two questions.
What could be the reason these functions do not return text but commands?
How to make your own function that returns similar commands.
R's graphics devices use the syntax defined in ?plotmath to distinguish between literal and formatted text. A basic feature of this syntax is that strings define literal text while functions define operations on text, such as juxtaposition and formatting (changing fonts, adding diacritics, getting whitespace right in mathematical formulae, etc.). What you are seeing, then, are unevaluated compositions of functions and strings defining formatted text. These are typically called plotmath expressions.
I could provide you with a basic example showing how different expressions translate to graphical output, but there is an excellent demo built into R: just run demo("plotmath") in an interactive R session and follow the prompts.
Functions that you can use to create expressions like the ones you are seeing include quote, substitute, bquote, and str2lang. You would probably use one of these to format, e.g., a plot title. Here is how I would use each function to generate the expression paste("Michaelis constant: ", italic("K")["M"], " = ", 0.015).
quote(
paste("Michaelis constant: ", italic("K")["M"], " = ", 0.015)
)
substitute(
paste("Michaelis constant: ", italic(sym)[sub], " = ", val),
list(sym = "K", sub = "M", val = 0.015)
)
sym <- "K"
sub <- "M"
val <- 0.015
bquote(
paste("Michaelis constant: ", italic(.(sym))[.(sub)], " = ", .(val))
)
str2lang(
'paste("Michaelis constant: ", italic("K")["M"], " = ", 0.015)'
)
The differences are subtle, so it could be worth browsing each function's help page and running the examples there.
Functions that you can use to create expression vectors include expression and str2expression. You would use one of these to format one or more labels at once, e.g., when defining axis tick labels. Here is how I would use each function to format labels for ticks at increasing powers of 10:
expression(10^0, 10^1, 10^2, 10^3, 10^4, 10^5)
str2expression(paste0(10, "^", 0:5))
Finally, here is a fun plot putting everything together:
plot.new()
plot.window(c(0, 1), c(1, 100000), log = "y")
box()
title(main = quote(paste("Michaelis constant: ", italic("K")["M"], " = ", 0.015)))
axis(side = 2, at = 10^(0:5), labels = str2expression(paste0(10, "^", 0:5)), las = 1)
text(x = seq(0, 1, by = 0.2), y = 10^(0:5), labels = str2expression(sprintf('%s("%s")', c("plain", "bold", "italic", "bolditalic", "symbol", "underline"), month.abb[1:6])))
For even more examples, take a look at ?plotmath.

saving and naming files in R automatically based on input filename

I have generated several Utilisation Distributions (UD) with AdehabitatHR and stored them as Geotiffs. I am now using the same UDs with the Lattice package to generate some maps and saving them to a high-res tiff image with LZW compression. Problem is that I have literally hundreds of maps to make, save and name. Is there a way automatically do this once i have loaded all the necessary files from a directory? Each one of my UDs has the following structure of the filename "UD_resolution_species_area_year_season. tif" and in the final name I give to my map I would like to keep the same structure (or entire filename) but add the prefix "blablabla_" e.g. "blablabla_UD_resolution_species_area_year_season.tiff". The image also include a main name, a capital letter, which should also change.
At the moment I am using the following:
rlist = list.files(getwd(), pattern = "tif$", full.names = FALSE)
for (i in rlist) {
assign(unlist(strsplit(i, "[.]"))[1], raster(i))
}
shplist = list.files(getwd(), pattern = "shp$", full.names = FALSE)
for (i in shplist) {
assign(unlist(strsplit(i, "[.]"))[1], readOGR(i))
}
UD <- 'UD_resolution_species_area_year_season'
ext <- extent(UD) + 0.3 # set the extent for the plot
aa <-
quantile(UD,
probs = c(0.25, 0.75),
type = 8,
names = TRUE)
my.at <- c(aa[1], aa[2])
my.at <- round(my.at, 3)
maxval <- maxValue(UD)
tiff(
"C:/myworkingdirectory/maps/blablabla_UD_resolution_species_area_year_season.tiff",
res = 600,
compression = "lzw",
width = 15,
height = 15,
units = "cm"
)
levelplot(
UD,
xlab = "",
ylab = "",
xlim = c(ext[1], ext[2]),
ylim = c(ext[3], ext[4]),
margin = FALSE,
contour = FALSE,
col.regions = viridis(1000),
colorkey = list(at = seq(0, maxval)),
main = "A",
maxpixels = 2e5
) + latticeExtra::layer(sp.polygons(Land, fill = "grey50", col = NA)) + contourplot(
`UD`,
at = my.at[1],
labels = FALSE,
margin = FALSE,
lty = 2,
col = "orange",
pretty = TRUE
) + contourplot(
UD,
at = my.at[2],
labels = FALSE,
margin = FALSE,
lty = 2,
col = "red",
pretty = TRUE,
)
dev.off()
It is a common beginners mistake to use assign. Do not use it, it creates the type of trouble you are now facing. In stead, you can make lists and/or use a loop.
Also what you are asking is basic R stuff, but you are complicating the question with adding lots of irrelevant detail about setting the extent, and levelplot. It is better to learn about doing these basic things by removing the clutter and focus on a simple case first. That is also how you should write questions for this forum.
In essence you have a bunch of files you want to process. Below I show how you can loop over a vector of the names and then loop and do what you need to do in that loop.
library(raster)
rastfiles <- list.files(pattern = "tif$", full.names=TRUE)
outputfiles <- file.path("output/path", paste0("prefix_", basename(rastfiles)))
for (i in 1:length(rastfiles))
r <- raster(rastfiles[i])
png(outputfiles[i])
plot(r)
dev.off()
}
You can also first read all the files into a list
rastfiles <- list.files(pattern = "tif$", full.names=TRUE)
rlist <- lapply(rastfiles, raster)
names(rlist) <- gsub(".tif$", "", basename(rastfiles))
rastfiles <- list.files(pattern = "shp$", full.names=TRUE)
slist <- lapply(shpfiles, readOGR)
names(slist) <- gsub(".shp$", "", basename(shpfiles))
And perhaps create a vector of output filenames
outputtif <- file.path("output/dir", basename(rastfiles))
And then loop over the items in the list, or the output filenames

Protected space and $ sign in R for latex extraction

I do multiple regression by group with a loop. I extract only 1 coefficient to which I attach stars according to this coef p-value.
Her is an example of my code:
for(i in 1:length(list)) {
# Equation
coef <- summary(lm(formula = var1 ~ var2 + var3 + var4,
data = subset(data.df, origin==var2[i])
),
)
# extraction
est <- coef$coefficients[2,1]
p <- coef$coefficients[2,4]
# Define notions for significance levels; spacing is important.
mystars <- ifelse(p < .001, "***",
ifelse(p < .01 , "** ",
ifelse(p < .05 , "* ",
" ")))
# past stars after estimate - put it in the matrix
est.mat[1,i] <- paste(sprintf('%.2f',est), mystars, sep = "", collapse = NULL)
# drop useless objects
rm(coef, est, t, p)
}
This works perfectly. Once done, I transfer my matrix est.mat into latex as follow:
print(xtable(est.mat, align = c("l","r","r","r","r","r","r"),
label = paste("tab:", file.name, sep = "", collapse = NULL),
caption = file.caption),
type = "latex",
size="\\normalsize",
caption.placement = "top",
file = paste("graphs/", file.name, ".tex", sep = "", collapse = NULL)
)
It works perfectly as well. The only problem is that, once printed in PDF the empty space after the stars defined in "mystar" are considered "un-existant" and therefore the coefficient numbers are not aligned, as illustrated below.
My question is then: How can I protect this space in "mystar" ?
One way to do this is to use "phantom" stars, which take up the same space as a star, but display nothing. I believe this modification of your code will do it:
mystars <- ifelse(p < .001, "***",
ifelse(p < .01 , "**\\phantom{*}",
ifelse(p < .05 , "*\\phantom{**}",
"\\phantom{***}")))
This will always leave space for three stars, so you might want to make it a little fancier by looking at the whole column first, and choosing how many phantom stars to add based on the most stars in the column. I'll leave that to you.
Edited to add: As described in Using xtable with R and Latex, math mode in column names?, print.xtable will escape the LaTeX macro, so it will display in the resulting PDF. But you can tell it not to, using argument sanitize.text.function:
print(xtable(est.mat, align = c("l","r","r","r","r","r","r"),
label = paste("tab:", file.name, sep = "", collapse = NULL),
caption = file.caption),
type = "latex",
size="\\normalsize",
caption.placement = "top",
file = paste("graphs/", file.name, ".tex", sep = "", collapse = NULL),
sanitize.text.function = function(x) x
)
This assumes that all of the table entries are legal LaTeX. If they are not, you may need a more complicated sanitization.

Function input used as string

saving_ggplot <- function(name = 'default', plotname = last_plot()) {
image_name = paste(name, ".png", sep="")
ggsave(image_name, plot = plotname,
scale = 1,
dpi = 300, limitsize = TRUE)
}
This is my function which saves a ggplot. However, I for the life of me cannot figure out how to take the name argument as a string.
for example if someone runes saving_ggplot(FILENAME, PLOTNAME)
it will just say no object FILENAME. In python I can just capture it and use it as str(), but using as.character or toString in R still doesn't work.
Error:
saving_ggplot(weightvsageTEST, weightvsageplot)
Error in paste(name, ".png", sep = "") :
object 'weightvsageTEST' not found
Successful call using ggsave:
ggsave('weightvsage.png', plot = last_plot(),
scale = 1,
dpi = 300, limitsize = TRUE)
You can use substitute():
saving_ggplot <- function(name, plotname) {
image_name = paste0(substitute(name), ".png") # paste0 removes need for sep arg
ggsave(image_name, plot = plotname,
scale = 1,
dpi = 300, limitsize = TRUE)
}
saving_ggplot(foo, p) # saves foo.png
Alternately, if you want to stay within tidyverse quasiquotation syntax, use enexpr() instead:
enexpr(name) # instead of substitute(name)
Data:
N <- 100
df <- data.frame(x=rnorm(n=N), y=rnorm(n=N))
p <- ggplot(df, aes(x,y)) + geom_smooth()

R: Get quantmod's chartSeries and AddTA to not show last value

When using chartSeries, by default it also shows on the top left of the plot the last value. Is there any way to prevent it from doing it?
When adding a new TA with addTA, you can avoid the last value on the plot by setting the argument legend = "", but only if you're making a new plot for the TA. If the TA is on a previously plotted graphic, it'll show the last value regardless of what you put in the legend argument.
getSymbols ("AAPL", src = "google")
chartSeries(AAPL)
What can I use here to prevent it from printing the last value on the plot?
addTA(EMA(Cl(AAPL)), on = 1, legend = "")
This still prints the last value on the top left of the plot. The weird part is that it doesn't do it if you're plotting on a new plot like this:
addTA(EMA(Cl(AAPL)), legend = "")
Is it like this by default, or is there something I can do to get around it?
The last value is shown by default (yes, annoyingly). You'll likely have to modify the source code to remove the last number showing in addTA.
I don't use addTA, but rather add_TA and chart_Series, because I think they look much better (second generation charts for quantmod). Here is a solution that removes the last number from showing for the add_TA version. But you must be willing to modify the source code.
In add_TA, you'll need to modify approximately lines 56-60 of the source:
Replace the text.exp, which is this:
# this is inside add_TA:
if (is.na(on)) {
plot_object$add_frame(ylim = c(0, 1), asp = 0.15)
plot_object$next_frame()
text.exp <- expression(text(x = c(1, 1 + strwidth(name)),
y = 0.3, labels = c(name, round(last(xdata[xsubset]),
5)), col = c(1, col), adj = c(0, 0), cex = 0.9,
offset = 0, pos = 4))
plot_object$add(text.exp, env = c(lenv, plot_object$Env),
with these modifications:
if (is.na(on)) {
plot_object$add_frame(ylim = c(0, 1), asp = 0.15)
plot_object$next_frame()
text.exp <- expression(text(x = c(strwidth(name)), # <- affects label on the subchart
y = 0.3, labels = name, col = c(col), adj = c(0), cex = 0.9,
offset = 1, pos = 4))
plot_object$add(text.exp, env = c(lenv, plot_object$Env),
expr = TRUE)
...
and assign this modified code to a new variable, called say add_TA.mine:
add_TA.mine <- function (x, order = NULL, on = NA, legend = "auto", yaxis = list(NULL,
NULL), col = 1, taType = NULL, ...)
{
lenv <- new.env()
lenv$name <- deparse(substitute(x))
lenv$plot_ta <- function(x, ta, on, taType, col = col, ...) {
xdata <- x$Env$xdata
....
[all the code for the rest of the function with modifications]....
}
}
plot_object
}
Now, just run the code with the modified function
library(quantmod)
getSymbols("AAPL")
environment(add_TA.mine) <- environment(get("add_TA", envir = asNamespace("quantmod")))
assignInNamespace(x = "add_TA", value = add_TA.mine, ns = "quantmod")
chart_Series(AAPL, subset = "2017")
add_TA(RSI(Cl(AAPL)))
quantmod:::add_TA(RSI(Cl(AAPL)))
You can see the last value is no longer printed:
(You could make the same kinds of changes in the old addTA code (perhaps via chartSeries if you really want to stick to the old plots)
If you're happy with the changes, and want to make them permament in add_TA, you can recompile the quantmod source code yourself with your modifications (i.e. you need to download the quantmod source code and recompile the package) . If you make a mess of things you can always redownload the original quandmod source code again.

Resources