echarts4r error at plotting barchart's colors - r

As you can see in the annexed image it seems that there is a problem with the e_visual_map() function from echarts4r. After y = aa the colors stop changing. Is there a way to fix the bar's colors?
data
library(dplyr)
library(viridis)
library(echarts4r)
df <- structure(
list(
Market = c("a", "b", "c", "d", "e",
"f", "g", "h", "i", "j",
"k", "l", "m", "n", "o",
"p", "q", "r", "s", "t",
"u", "v", "w", "x", "y",
"z", "aa", "bb", "cc",
"dd", "ee", "ff", "gg",
"hh", "ii", "jj", "kk",
"ll", "mm", "nn", "oo",
"pp", "qq", "rr", "ss",
"tt", "uu", "vv"),
Percent_Change = c(5.16901350940851, 3.91868856906443, 3.41802504497987, 3.16413673886071,
3.12684219659363, 2.89249688621206, 2.87284606849977, 2.84454222482254,
2.57058275282915, 2.43282934768581, 2.34818492965906, 2.30880001810456,
2.2918613260413, 2.24101659933832, 2.18752627680741, 2.10073586714032,
1.86045092759311, 1.85290305266011, 1.68128474330245, 1.54700002004653,
1.5303536712395, 1.52152376952798, 1.45917880532612, 1.4355692973819,
1.4257368870892, 1.36409659669896, 1.22315092771929, 1.04309133074753,
0.939025651002292, 0.844389462321624, 0.797407599768931, 0.681691408815433,
0.242176237950194, 0.237798995363376, 0.219182593926239, -0.0280421490193321,
-0.111286439923117, -0.124395342178022, -0.175922623382462, -0.188080671185304,
-0.870155958402443, -1.60611679230328, -1.66206110148814, -1.82732601610943,
-3.68051100830324, -4.43292411223474, -9.42691532047856, -10.5405968097707)),
row.names = c(NA, -48L), class = c("tbl_df", "tbl", "data.frame"))
code to plot
df %>% arrange(Percent_Change) %>%
# mutate(Market = fct_reorder(Market, -Percent_Change)) %>%
e_chart(Market) %>% e_bar(Percent_Change) %>%
e_visual_map(Percent_Change, scale = e_scale, color = viridis(100)) %>%
e_flip_coords() %>%
e_legend(show = F) %>%
e_color(background = c("#343E48"))
Results


Not 100% about your desired result. If you want to color your bars according to the value of PercentChange than this could be achieved by setting dimension=0 to color by the x axis and getting rid of scale:
library(dplyr)
library(viridis)
library(echarts4r)
df %>%
arrange(Percent_Change) %>%
e_chart(Market) %>%
e_bar(Percent_Change) %>%
e_visual_map(Percent_Change,
color = viridis(10),
dimension = 0
) %>%
e_flip_coords() %>%
e_legend(show = FALSE) %>%
e_color(background = c("#343E48"))

Related

How to deal with uneven spaces between bars in stacked barplot generated with ggplot2?

I have created a stacked barplot with ggplot2. I noticed that the gaps between the bars are not the same. This is strange, as while the problem is recuring on my particular data set, I can't seem to recreate it in a reproducible manner on an exemplary frame of data.
Here is what I have done:
a <- c("A", "B", "C", "D", "E", "F", "G", "H", "A", "B", "C","C", "D", "E", "F", "I", "J", "K", "L", "M", "N", "C", "C", "C", "C", "C", "O", "P", "R", "S", "T", "U", "W")
b <- c("kk", "ll", "ss", "ff", "kk", "ll", "ss", "ff", "kk", "ll", "ss", "ff", "kk", "ll", "ss", "ll", "ss", "ff", "kk", "ll", "ss", "ss", "ss", "ss", "ss", "ss", "kk", "ll", "ss", "ff", "kk", "ss", "ss")
df <- data.frame(a, b)
ggplot(df)+
geom_bar(aes(y = fct_infreq(a), fill = b, ), color = "black")+
theme_classic()+
labs(x = "\n", y = "\n")+
guides(fill=guide_legend(title = "Subunit"))+
ggtitle("Variation in the number of a in b \n\n")+
theme(plot.title = element_text(color="black", size=14, face="bold.italic", hjust = 0.5))+
scale_x_continuous(breaks = seq(0, 20, by = 1))+
expand_limits(x = c(0, 20))+
scale_fill_brewer(palette="Dark2")
This exemplary code returns this plot:
As you can see, everything looks fine.
This is what I get, when I run my set through the same code:
The red arrows indicate the gaps, that are noticeably thinner than other gaps.
Please advise how to correct this.

Sort table in descending order

Based on the data and code below, is it possible to sort the table in descending order?
Data (df):
structure(list(CITYNAME = c("a", "b", "c",
"d", "e", "f", "g",
"h", "i", "j", "k",
"l", "m", "n", "p", "q",
"r", "s", "t", "u",
"w", "x", "y", "z"), AvgPpt = c(127.785,
131.456, 128.357, 114.792, 131.383, 129.696, 137.008, 136.129,
132.881, 131.676, 129.103, 132.475, 122.263, 132.393, 134.552,
120.322, 125.987, 132.337, 131.18, 122.705, 123.285, 128.853,
134.494, 114.154)), row.names = c(NA, -24L), class = c("tbl_df",
"tbl", "data.frame"))
Code:
library(ggpubr)
tbl_ppt = df %>%
ggtexttable(cols = c("Municipilality", "Average Precipitaiton (mm)"),
rows = NULL,
theme = ttheme("mBlue"))
tbl_ppt

You could arrange your data in your desired order before passing it to ggtexttable:
library(ggpubr)
library(dplyr)
df %>%
arrange(desc(AvgPpt)) %>%
ggtexttable(cols = c("Municipilality", "Average Precipitaiton (mm)"),
rows = NULL,
theme = ttheme("mBlue"))

Applying colors dynamically to table cells in R

I have a data frame in R that looks like this:
It is 84 rows high and 365 rows wide. The dput is below. What I'm trying to figure out is how to get each cell to change color based on the symbol that's in the cell (also, I don't want to see the column name, row name, or gridlines). I've tried kable, DT, base R, heatmap, and huxtable. The closest I've gotten is with DT:
datatable(cover, rownames=FALSE, options = list(dom = 't')) %>% formatStyle(names(cover), backgroundColor=styleEqual(hex$Symbol, hex$Hex))
Here's the result from that code:
I haven't been able to figure out how to also remove the column names (so the columns are only as wide as the symbol) or the gridlines. I'm sure there's a way to do this but I've been spinning my wheels for a couple days so I thought I'd ask the experts. I'm still fairly new with R (I'm a data analyst, not a professional coder). My ultimate goal is for it to look something like this (which was created with Google Sheets conditional formatting):
dput of the head of the first 10 columns of the data table:
structure(list(`2019-01-01` = c("f", "f", "f", "<U+263D>", "<U+263D>", "<U+263D>"), `2019-01-02` = c("<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-03` = c("t", "t", "t", "d", "d", "d"), `2019-01-04` = c("d", "d", "d", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-05` = c("&", "&", "&", "&", "&", "&"), `2019-01-06` = c("<U+2699>", "<U+2699>", "<U+2699>", "&", "&", "&"), `2019-01-07` = c("^", "^", "^", "^", "^", "^"), `2019-01-08` = c("&", "&", "&", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-09` = c("<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-10` = c("s", "s", "s", "s", "s", "s")), row.names = c(NA, 6L), class = "data.frame")
dput of the Symbol to Hex lookup table:
structure(list(Symbol = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "a","i", "k", "b", "l", "r", "c", "x", "#", "%", "^", "e", "m", "s", "#", "<U+270E>", "&", "<U+2699>", "d", "t", "y", "n", "<U+25C0>", "<U+263D>", "f", "<U+2689>", "<U+2726>", "<U+0394>", "¥", "p", "u", "<U+2326>", "<U+26AF>", "z", "<U+2714>", "o", "+", "v", "g", "<U+262F>", "<U+2724>", "<U+272B>", "<U+2766>", "j", "q", "h", "<U+2665>", "w"), Hex = c("#572433", "#72375D", "#633666", "#803A6B", "#6C3A6E", "#776B98", "#ADA7C7", "#5C7294", "#7B8EAB", "#707DA2", "#555B7B", "#464563", "#0E365C", "#11416D", "#13477D", "#2C597C", "#396987", "#4781A5", "#35668B", "#5A8FB8", "#3B768F", "#4F93A7", "#5BA3B3", "#90C3CC", "#C4DECC", "#7BAC94", "#5B9071", "#396F52", "#044D33", "#313919", "#424D21", "#4C5826", "#72843C", "#94AB4F", "#AEBF79", "#CCD9B1", "#D8E498", "#FFFB8B", "#FDF9CD", "#FFF1AF", "#FDD755", "#FFC840", "#FFBF57", "#FFA32B", "#FF8B00", "#F67F00", "#F27842", "#FF836F", "#E96A67", "#FF7992", "#E74967", "#BA4A4A", "#B33B4B", "#970B23", "#87071F", "#A7132B", "#913546")), row.names = c(NA, -57L), spec = structure(list(cols = list(Index = structure(list(), class = c("collector_double", "collector")), Color = structure(list(), class = c("collector_double", "collector")), `Color name` = structure(list(), class = c("collector_character", "collector")), Symbol = structure(list(), class = c("collector_character", "collector")), Hex = structure(list(), class = c("collector_character", "collector"))), default = structure(list(), class = c("collector_guess", "collector")), skip = 1), class = "col_spec"), class = c("spec_tbl_df", "tbl_df", "tbl", "data.frame"))
Here's the code I'm using per the comments below. It worked last week but now it isn't. I've determined through going line by line that value2 isn't rendering properly, but I've checked it against the code provided and it looks exactly the same. I'm calling the dataset "cover" and the color table "hex".
hexcol <- hex$Hex
names(hexcol) <- hex$Symbol
bcol <- function(x){hexcol[as.character(x)]}
x <- cover %>%
dplyr::mutate(row.id = 1:n()) %>%
gather(key = "key", value = "value", -row.id) %>%
mutate(value2 = " ", value2 = cell_spec(value2, background = mapply(bcol, value), color = mapply(bcol, value))) %>%
select(-value) %>%
spread(key = key, value = value2) %>%
select(-row.id) %>%
kable(format = "html", escape = F) %>%
kable_styling(full_width = F)
x2 <- gsub("<thead>.*</thead>", "", x)
x3.splits <- unlist(str_split(x2, pattern = "\n"))
x3.cols <- str_extract(x3.splits, pattern = "#[0-9a-fA-F]{6}")
x3.vals <- str_extract(x3.splits, pattern = "(a-Z0-9)+")
# cycle through each row of HTML code to find and replace any value with HTML/CSS code to color the background of that specific cell
for (i in 1:length(x3.splits)){
if (!is.na(x3.cols[i])){
x2 <- gsub(pattern = x3.splits[i],
replacement = paste0('<td style="text-align:center; background-color: ', x3.cols[i], '; border-top: 1px solid ',
x3.cols[i], ';"><span style="margin-left:5px;margin-right:5px"> </span></td>'), x = x2)
}
}
Here's the session info:

Have you tried using the kableExtra package? I was able to do the following which I think does what you're hoping to do using this package as well as some HTML syntax/regular expression substitutions. Let me know if this doesn't seem to work for you though!
library(kableExtra)
library(stringr)
library(dplyr)
library(tidyr)
library(magick)
library(webshot)
dat <- structure(list(`2019-01-01` = c("f", "f", "f", "<U+263D>", "<U+263D>", "<U+263D>"), `2019-01-02` = c("<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-03` = c("t", "t", "t", "d", "d", "d"), `2019-01-04` = c("d", "d", "d", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-05` = c("&", "&", "&", "&", "&", "&"), `2019-01-06` = c("<U+2699>", "<U+2699>", "<U+2699>", "&", "&", "&"), `2019-01-07` = c("^", "^", "^", "^", "^", "^"), `2019-01-08` = c("&", "&", "&", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-09` = c("<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-10` = c("s", "s", "s", "s", "s", "s")), row.names = c(NA, 6L), class = "data.frame")
col.tab <- structure(list(Symbol = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "a","i", "k", "b", "l", "r", "c", "x", "#", "%", "^", "e", "m", "s", "#", "<U+270E>", "&", "<U+2699>", "d", "t", "y", "n", "<U+25C0>", "<U+263D>", "f", "<U+2689>", "<U+2726>", "<U+0394>", "¥", "p", "u", "<U+2326>", "<U+26AF>", "z", "<U+2714>", "o", "+", "v", "g", "<U+262F>", "<U+2724>", "<U+272B>", "<U+2766>", "j", "q", "h", "<U+2665>", "w"), Hex = c("#572433", "#72375D", "#633666", "#803A6B", "#6C3A6E", "#776B98", "#ADA7C7", "#5C7294", "#7B8EAB", "#707DA2", "#555B7B", "#464563", "#0E365C", "#11416D", "#13477D", "#2C597C", "#396987", "#4781A5", "#35668B", "#5A8FB8", "#3B768F", "#4F93A7", "#5BA3B3", "#90C3CC", "#C4DECC", "#7BAC94", "#5B9071", "#396F52", "#044D33", "#313919", "#424D21", "#4C5826", "#72843C", "#94AB4F", "#AEBF79", "#CCD9B1", "#D8E498", "#FFFB8B", "#FDF9CD", "#FFF1AF", "#FDD755", "#FFC840", "#FFBF57", "#FFA32B", "#FF8B00", "#F67F00", "#F27842", "#FF836F", "#E96A67", "#FF7992", "#E74967", "#BA4A4A", "#B33B4B", "#970B23", "#87071F", "#A7132B", "#913546")), row.names = c(NA, -57L), spec = structure(list(cols = list(Index = structure(list(), class = c("collector_double", "collector")), Color = structure(list(), class = c("collector_double", "collector")), `Color name` = structure(list(), class = c("collector_character", "collector")), Symbol = structure(list(), class = c("collector_character", "collector")), Hex = structure(list(), class = c("collector_character", "collector"))), default = structure(list(), class = c("collector_guess", "collector")), skip = 1), class = "col_spec"), class = c("spec_tbl_df", "tbl_df", "tbl", "data.frame"))
color_mapper <- col.tab$Hex
names(color_mapper) <- col.tab$Symbol
c_func <- function(x){
color_mapper[as.character(x)]
}
x <- dat %>%
mutate(row.id = 1:n()) %>%
gather(key = "key", value = "value", -row.id) %>%
mutate(value2 = " ",
value2 = cell_spec(value2, background = mapply(c_func, value), color = mapply(c_func, value))
) %>%
select(-value) %>%
spread(key = key, value = value2) %>%
select(-row.id) %>%
kable(format = "html", escape = F) %>%
kable_styling(full_width = F)
x2 <- gsub("<thead>.*</thead>", "", x)
x3.splits <- unlist(str_split(x2, pattern = "\n"))
x3.cols <- str_extract(x3.splits, pattern = "#[0-9a-fA-F]{6}")
x3.vals <- str_extract(x3.splits, pattern = "(a-Z0-9)+")
## cycle through each row of HTML code to find and replace any value with
## HTML/CSS code to color the background of that specific cell
for (i in 1:length(x3.splits)){
if (!is.na(x3.cols[i])){
x2 <- gsub(
pattern = x3.splits[i],
replacement = paste0('<td style="text-align:center; background-color: ', x3.cols[i], '; border-top: 1px solid ', x3.cols[i], ';"><span style="margin-left:5px;margin-right:5px"> </span></td>'),
x = x2
)
}
}
x2 %>%
save_kable("my_image.png")
With the PNG output:

Here's a quick example using huxtable (I'm the package author):
tmp <- structure(list(`2019-01-01` = c("f", "f", "f", "<U+263D>", "<U+263D>", "<U+263D>"), `2019-01-02` = c("<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-03` = c("t", "t", "t", "d", "d", "d"), `2019-01-04` = c("d", "d", "d", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-05` = c("&", "&", "&", "&", "&", "&"), `2019-01-06` = c("<U+2699>", "<U+2699>", "<U+2699>", "&", "&", "&"), `2019-01-07` = c("^", "^", "^", "^", "^", "^"), `2019-01-08` = c("&", "&", "&", "<U+270E>", "<U+270E>", "<U+270E>"), `2019-01-09` = c("<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>", "<U+2699>"), `2019-01-10` = c("s", "s", "s", "s", "s", "s")), row.names = c(NA, 6L), class = "data.frame")
ht <- as_hux(tmp)
ht <- map_background_color(ht, by_values("<U+270E>" = "red", "<U+2699>" = "green"))
I haven't used your exact symbol table. If it is large, you might want to do something like do.call(by_values, my_symbols) where my_symbols would be something like list("1" = "#572433", ...).

Error for graph saving loop - Must be length 1 (a summary value)

I'm trying to create and save graphs for individual organizations. I keep getting an error that says "Error in summarise_impl(.data, dots) :
Column Improved must be length 1 (a summary value), not 0"
The graphs work when I combine all the organizations together, so I'm not sure what is going on here!
Starting with this data:
library(ggpubr)
structure(list(Organization = c("A", "B", "C", "D", "E", "F",
"G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S"
), imp_imp20_Improved = c(55.6, 100, 50, 0, 57.1, 0, 0, 45, 50,
60, 100, 50, 66.7, 66.7, 33.3, 0, 50, 0, 50)), row.names = c(NA,
-19L), class = c("tbl_df", "tbl", "data.frame"))
org<- c("A", "B", "C", "D", "E", "F",
"G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S"
)
This is my code for the graph loop:
for(i in org) {
tiff(paste0("//graphs/",i,"_graph11.tiff"), units="in", width=3.5, height=3, res=300)
indicator_graph1<- indicators_ong %>%
filter(Organization==i) %>%
summarise(Improved = imp_imp20_Improved,
"Not Improved" = 100-imp_imp20_Improved)%>%
gather(key="group") %>%
arrange(desc(group))
labs <- paste0(indicator_graph1$group, "\n (", indicator_graph1$value,"%)")
z <- ggpie(indicator_graph1,"value",label=labs, fill= "group", color = "black", palette = c("darkgoldenrod1","azure3"), lab.pos = "in", lab.font = c(3,"black"),title="Improve 20")+
theme(legend.position ="none")+
font("title", size=10, hjust=0.5)
print(z)
dev.off()
}

Distance matrix from proxy package into a dataframe

I have a distance matrix from this code
I would like to convert the distanceMatrix into a dataframe. I use this:
library(reshape2)
melt(distanceMatrix)
or
as.data.frame(distanceMatrix)
and I receive this error:
Error in as.data.frame.default(x[[i]], optional = TRUE) :
cannot coerce class ""crossdist"" to a data.frame
Data
distanceMatrix <-
structure(c(1.1025096478618, 2.48701192612548, 1.81748937453859,
0.68928345814907, 3.4194165172611, 1.39021901561926, 0.696405607391678,
1.09511501308162, 0.733071057157832, 0.894074317336616, 0.274302486490285,
2.00790247099612, 2.03702210657379, 0.790303515570192, 0.76573433957666,
1.0571870370502, 2.08607605440225, 1.18691928628668, 0.950127106192438,
1.90183580897689, 1.06791623757733, 1.95426617861089, 1.28359907050968,
0.639828869115434, 1.2125883228325, 1.17334881171837, 2.86424081724093,
4.29579721901031, 2.48106485650871, 2.47992202769688, 4.78094585963798,
3.08269692108197, 2.51054397059837, 2.78351950724781, 1.9552995309483,
1.02672164296738, 2.04833064878561, 2.40777909325915, 1.37714830319657,
2.54290296394426, 1.99486295133513, 1.42661425293529, 2.75973709232752,
0.632464187558431, 2.64349038129557, 3.04900615202494, 1.34349249286485,
0.66548291586285, 1.14201671902258, 2.20314775706901, 3.027560891124,
2.58016468923376, 0.701837450761437, 1.82650318310107, 1.17318969224049,
0.898229996978744, 2.04804918964036, 0.510384590416117, 1.20067408397491,
0.479351971313752, 0.900264653292786, 2.17660319096498, 1.11774249289539,
1.50312712068438, 2.35380779446751, 0.74568873241509, 0.860144296532242,
1.49609968893816, 1.27903173482324, 2.30242237929782, 0.546178045451667,
0.696804454166844, 1.57330737370915, 3.18912158434627, 2.63481498585198,
0.743304574607114, 1.2813138290548, 0.278296684614969), .Dim = c(26L,
3L), .Dimnames = list(c("a", "b", "c", "d", "e", "f", "g", "h",
"i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u",
"v", "w", "x", "y", "z"), c("A", "B", "C")), class = "crossdist", method = "Euclidean", call = proxy::dist(x = voterIdealPoints,
y = candidateIdealPoints))

Use
as.dataframe(as.matrix(distanceMatrix))

Resources