6  Rozszerzenia dla pakietu ggplot2

library(ggplot2)
library(patchwork)
library(ggcorrplot)
library(GGally)
library(ggExtra)
library(ggside)
library(ggridges)
library(ggmosaic)
library(ggmulti)

corr <- round(cor(mtcars[,c(1,4,6,7)]), 2)
corr

       mpg    hp    wt  qsec
mpg   1.00 -0.78 -0.87  0.42
hp   -0.78  1.00  0.66 -0.71
wt   -0.87  0.66  1.00 -0.17
qsec  0.42 -0.71 -0.17  1.00

p.mat <- cor_pmat(mtcars[,c(1,4,6,7)])
p.mat

              mpg           hp           wt         qsec
mpg  0.000000e+00 1.787835e-07 1.293959e-10 1.708199e-02
hp   1.787835e-07 0.000000e+00 4.145827e-05 5.766253e-06
wt   1.293959e-10 4.145827e-05 0.000000e+00 3.388683e-01
qsec 1.708199e-02 5.766253e-06 3.388683e-01 0.000000e+00

ggcorrplot

# Ilustracja macierzy współczynników korelacji
ggcorrplot(corr)

# Ilustracja macierzy współczynników korelacji - koła
ggcorrplot(corr, method = "circle")

# Ilustracja macierzy współczynników korelacji - zaznaczenie nieistotnych zależności
ggcorrplot(corr, p.mat = p.mat, method = "circle")

# Ilustracja macierzy współczynników korelacji - nieistotne zalezności jako białe pola
ggcorrplot(corr, p.mat = p.mat,
  hc.order = TRUE, insig = "blank")

# Ilustracja macierzy współczynników korelacji z ich wartościami
ggcorrplot(corr, hc.order = TRUE,
           type = "lower", lab = TRUE)

GGally

# Macierzowy wykres rozrzutu
ggpairs(mtcars[,c(1,4,6,7)]) 

# Macierzowy wykres rozrzutu
ggpairs(mtcars,columns = c(1,4,6,7))

# Macierzowy wykres rozrzutu z wyróżnieniem kategorii
ggpairs(mtcars, columns = c(1,4,6,7),aes(colour=factor(cyl))) 

# Macierzowy wykres rozrzutu z wykresami gęstości
ggpairs(
  mtcars[, c(1, 4, 6,7)],
  upper = list(continuous = "density", combo = "box_no_facet"),
  lower = list(continuous = "points", combo = "dot_no_facet")
)

# Macierzowy wykres rozrzutu z wykresami pudełkowymi
data(mtcars)
mtcars$cyl=factor(mtcars$cyl)
ggpairs(
  mtcars, columns =  c("mpg", "wt", "cyl"),
  lower = list(
    continuous = "smooth",
    combo = "facetdensity",
    mapping = aes(color = cyl)
  )
)

# Macierzowy wykres rozrzutu z wykresami pudełkowymi i słupkowym oraz z wyróżnieniem kategorii
ggpairs(mtcars, columns = c("mpg", "wt", "cyl"), columnLabels = c("mpg", "wt", "cyl"),aes(color=cyl))

# Oszacowania funkcji gęstości – wykres panelowy
ggally_facetdensity(mtcars[,c(1,2)],aes(x=mpg,y=cyl)) +
  labs(x="Liczba mil przejechanych na galonie paliwa")

ggExtra

# Wykres rozrzutu – konstrukcja obiektu p
p <- ggplot(mtcars, aes(wt, mpg)) + 
  geom_point() + 
  labs(x='Waga samochodu',y='Liczba mil przejechanych na galonie paliwa')+
  theme_bw()
p

# Wykres rozrzutu z rozkładami brzegowymi
ggMarginal(p)

# Wykres rozrzutu z rozkładami brzegowymi z wyróżnieniem kategorii
p <- ggplot(mtcars, aes(wt, mpg, colour = cyl)) +
  geom_point()+
    labs(x='Waga samochodu',y='Liczba mil przejechanych na galonie paliwa',color='Liczba cylindrów')+
  theme(legend.position='bottom')
ggMarginal(p, groupColour = TRUE, groupFill = TRUE)

# Wykres rozrzutu z rozkładami brzegowymi w postaci histogramów
ggMarginal(p, type = "histogram",fill = "blue")

# Wykres rozrzutu z rozkładami brzegowymi w postaci wykresów pudełkowych
ggMarginal(p,  size = 10, type = "boxplot",
           col = "blue", fill = "orange")

ggsides

# Wykres rozrzutu z gęstościami brzegowymi i wyróżnionymi kategoriami
ggplot(mtcars, aes(wt, mpg, colour = cyl)) + 
  geom_point(size = 2) +
  geom_xsidedensity(aes(y = after_stat(density)), position = "stack") +
  geom_ysidedensity(aes(x = after_stat(density)), position = "stack") +
  labs(x='Waga samochodu',y='Liczba mil przejechanych na galonie paliwa',colour='Liczba cylindrów')+
  theme(legend.position='bottom',axis.text.x = element_text(angle = 90))

# Wykres rozrzutu z brzegowymi gęstościa i wykresem pudełkowym i wyróżnionymi kategoriami
ggplot(mtcars, aes(wt, mpg, colour = cyl)) + 
  geom_point(size = 2) +
  geom_xsideboxplot(aes(y =cyl), orientation = "y") +
  scale_xsidey_discrete() + #In order to use xsideboxplot with a main panel that uses
  geom_ysidedensity(aes(x = after_stat(density)), position = "stack") +
  scale_ysidex_continuous(guide = guide_axis(angle = 90), minor_breaks = NULL) +
  labs(x='Waga samochodu',y='Liczba mil przejechanych na galonie paliwa',colour='Liczba cylindrów')+
  theme(legend.position='bottom',ggside.panel.scale = .3)

# Wykres rozrzutu z rozkładami brzegowymi w formie gęstości i pudełkowego oraz z wyróżnionymi kategoriami
ggplot(mtcars, aes(wt, mpg, colour = cyl)) + 
  geom_point(aes(color = cyl)) +
  geom_xsidedensity(alpha = .3, position = "stack") +
  geom_ysideboxplot(aes(x = cyl), orientation = "x") +
  scale_ysidex_discrete(guide = guide_axis(angle = 45)) +
  labs(x='Waga samochodu',y='Liczba mil przejechanych na galonie paliwa',colour='Liczba cylindrów')+
  theme(legend.position='bottom',ggside.panel.scale = .3,
        ggside.panel.border = element_rect(NA, "blue", linewidth = 1),
        ggside.panel.grid = element_line("black", linewidth = .1, linetype = "dotted"),
        ggside.panel.background = element_blank()) +
  guides(color = "none", fill = "none")

ggmulti

# Wykres współrzędnych równoległych
p <- ggplot(mtcars, 
      mapping = aes(wt = wt,hp = hp,qsec = qsec,mpg = mpg,
                colour = cyl)) +
  geom_path(alpha = 0.4) +
  theme(legend.position='bottom')+
  coord_serialaxes(axes.layout = "parallel",scaling = "variable")
p

# Wykres radarowy
p+
  coord_serialaxes(axes.layout =  "radial",scaling = "variable")

# Wykres współrzędnych równoległych z histogramami
p + 
  geom_histogram(mapping = aes(fill = cyl), alpha = 0.5)

ggridges

# Wykres gęstości względem wyróżnionych kategorii
ggplot(mtcars, aes(x = mpg, y = cyl, group = cyl)) + 
    labs(x='Liczba mil przejechanych na galonie paliwa',y='Liczba cylindrów')+
  geom_density_ridges()

# Wykres gęstości względem wyróżnionych kategorii z natężeniem wartości
ggplot(mtcars, aes(x = mpg, y = cyl, fill = after_stat(x))) +
  geom_density_ridges_gradient(scale = 5, rel_min_height = 0.01) +
  labs(x='Liczba mil przejechanych na galonie paliwa', y='Liczba cylindrów')+
  theme(legend.position='none')

# Wykres gęstości względem wyróżnionych kategorii z rozrzuconymi obserwacjami
ggplot(mtcars, aes(x = mpg, y = cyl, fill = cyl)) +
  geom_density_ridges(
    aes(point_color = cyl, point_fill = cyl, point_shape = cyl),
    alpha = .2, point_alpha = 1, jittered_points = TRUE  ) +
  labs(x='Liczba mil przejechanych na galonie paliwa', y='Liczba cylindrów')+
    theme(legend.position='bottom')+
  scale_point_color_hue(l = 40) +
  scale_discrete_manual(aesthetics = "point_shape", values = c(21, 22, 23))

# Panele wykresu gęstości względem wyróżnionych kategorii 
ggplot(mtcars, aes(x = mpg, y = cyl)) + 
  geom_density_ridges(scale = 1) + 
    labs(x='Liczba mil przejechanych na galonie paliwa', y='Liczba cylindrów')+
  facet_wrap(~am)

ggmosaic

# Wykres mozaikowy
library(ggmosaic)

data(mtcars)
# Zmiana trzech zmiennych na czynniki (factors)
mtcars$gear <- factor(mtcars$gear,levels=c(3,4,5),labels=c('3 biegi', '4 biegi', '5 biegów'))
mtcars$am <- factor(mtcars$am, levels = c(0,1), labels = c('automatyczna','ręczna'))
mtcars$cyl <- factor(mtcars$cyl,levels=c(4,6,8),labels=c('4 cylindry', '6 cylindrów', '8 cylindrów'))

ggplot(mtcars) +
geom_mosaic(aes(x = product(cyl), fill = gear))+
    labs(x='Liczba cylindrów', y='Liczba biegów',fill='Liczba biegów')

# Wykres mozaikowy
ggplot(mtcars) +
  geom_mosaic(aes(x = product(cyl,am), fill = gear))+
       labs(x='Liczba cylindrów : rodzaj skrzyni biegów', y='Liczba biegów')+
  theme(legend.position = 'none')

# Wykres mozaikowy w układzie panelowym
ggplot(mtcars) +
  geom_mosaic(aes(x = product(cyl), conds=product(gear), fill = am))+
  labs(y='Liczba cylindrów ', x='Liczba biegów : rodzaj skrzyni biegów',fill="Skrzynia biegów")+
  coord_flip()+
  facet_wrap(~vs)+
  theme(legend.position = 'bottom')

Inne

library(ggChernoff)
library(HistData)
library(aplpack)
library(car)
library(reshape2)
library(vcd)

Mozaikowe

# Konstrukcja wykresu mozaikowego
mosaic(Titanic,shade=TRUE)

# Konstrukcja wykresu sita
tit <- margin.table(Titanic, c(2,1,4))
sieve(tit,  shade = TRUE)

# Konstrukcja wykresu asocjacji par 
pairs(Titanic,upper_panel = pairs_assoc)

Twarze Chernoffa

# Konstrukcja wykresu twarzy Chernoffa 
ggplot(mtcars) +
  aes(wt, mpg, fill = factor(cyl),smile=disp) +
  labs(fill='Liczba cylindrów')+
  theme(legend.position='bottom')+
  geom_chernoff()

# Załadowanie zbioru i konstrukcja wykresu
data(mtcars)
faces(mtcars)

effect of variables:
 modified item       Var   
 "height of face   " "mpg" 
 "width of face    " "cyl" 
 "structure of face" "disp"
 "height of mouth  " "hp"  
 "width of mouth   " "drat"
 "smiling          " "wt"  
 "height of eyes   " "qsec"
 "width of eyes    " "vs"  
 "height of hair   " "am"  
 "width of hair   "  "gear"
 "style of hair   "  "carb"
 "height of nose  "  "mpg" 
 "width of nose   "  "cyl" 
 "width of ear    "  "disp"
 "height of ear   "  "hp"  

Wykres ciepła

# Wykres ciepła z użyciem funkcji heatmap
mtcars_matrix <- as.matrix(mtcars[,c(1,3,4,5,6,7)])
heatmap(mtcars_matrix, scale = "column", Colv = NA, Rowv = NA, col = heat.colors(256), xlab = "Zmienna")

# Konstrukcja wykresu heatmap
library(dplyr)
data(mtcars)
mtcars_std <- mtcars %>%
  mutate_if(is.numeric, scale)
mtcars_std=mtcars_std[,c(1,3,4,5,6,7)]
mtcars_std$model=rownames(mtcars_std)
mtcars_melted <- melt(mtcars_std, id.vars = "model")
ggplot(mtcars_melted, aes(x = variable, y = model, fill = value)) +
  geom_tile() +
  scale_fill_gradient2(low = "lightblue", high = "darkblue") +
  labs(title = "Wykres ciepła z pakietu ggplot2", x = "Cechy samochodów", y = "Nazwy samochodów") +
  theme_minimal()

Róża Nightingale

# Konstrukcja wykresu róża Nightingale
library(tidyverse)
Nightingale %>%
  select(Date, Month, Year, contains("rate")) %>%
  pivot_longer(cols = 4:6, names_to = "Cause", values_to = "Rate") %>%
  mutate(Cause = gsub(".rate", "", Cause),
         period = ifelse(Date <= as.Date("1855-03-01"), "Kwiecień 1854 do Marzec 1855", "Kwiecień 1855 to Marzec 1856"),
         Month = fct_relevel(Month, "Jul", "Aug", "Sep", "Oct", "Nov", "Dec", "Jan", "Feb", "Mar", "Apr", "May", "Jun")) %>%
  ggplot(aes(Month, Rate)) +
  geom_col(aes(fill = Cause), width = 1, position = "identity") +
  coord_polar() +
  facet_wrap(~period) +
  scale_fill_manual(values = c("skyblue3", "grey30", "firebrick")) +
  scale_y_sqrt() +
  theme_void() +
  theme(axis.text.x = element_text(size = 9),
        strip.text = element_text(size = 11),
        legend.position = "bottom",
        plot.background = element_rect(fill = alpha("cornsilk", 0.5)),
        plot.margin = unit(c(10, 10, 10, 10), "pt"),
        plot.title = element_text(vjust = 5)) +
   ggtitle("Róża Nightingale")

Gwiazdowy

# Konstrukcja wykresu gwiazdowego
palette(rainbow(12, s = 0.6, v = 0.75))
stars(mtcars, draw.segments = TRUE, key.loc = c(13, 2.2))

# Konstrukcja wykresu gwiazdowego
stars(mtcars[1:5,c(1,3,4,6,7)], draw.segments = TRUE, key.loc = c(5.8, 2.2))

Słonecznikowy

data(Galton)
with(Galton,
        {
        sunflowerplot(parent,child, xlim=c(62,74), ylim=c(62,74),xlab='Wzrost rodzica',ylab='Wzrost dziecka')
        reg <- lm(child ~ parent)
        abline(reg, col='blue',lwd=2)
        dataEllipse(parent,child, plot.points=FALSE)
  })

# Konstrukcja wykresu słonecznikowego – wersja ggplot2
ggplot(Galton, aes(x = round(parent), y = round(child))) +
    geom_count(color='red') +
    stat_ellipse(type = "norm", level = 0.9,color='blue') +
    stat_ellipse(type = "norm", level = 0.5,color='blue') +
    geom_smooth(method = "lm", se = FALSE, color = "blue") +
    lims(x=c(60,76),y=c(60,76))+    
    theme_minimal() +
    labs(x = "Wzrost rodzica",y = "Wzrost dziecka")

Pudełkowy 2D

# Konstrukcja wykresu pudełkowego 2D
bagplot(mtcars[,c(6,4)],factor=2.5,create.plot=TRUE,approx.limit=300,xlab='Waga samochodu',ylab='Moc silnika')

# Konstrukcja wykresu boxplot2D
mt=cbind(mtcars[,6],mtcars[,1])
plot(mt, xlab='Waga samochodu',ylab='Liczba mil przejechanych na galonie paliwa')
boxplot2D(mt,box.shift=-40,angle=3,angle.typ=1)
boxplot2D(mt,box.shift=-110,angle=90,angle.typ=1)
boxplot2D(mt,box.shift=-40,angle=11.6,angle.typ=1)

Podsumowanie zmiennych

# Konstrukcja wykresu podsumowania zmiennych
library(aplpack)
plotsummary(mtcars[,c(1,4,6,7)],types=c("ecdf", "density", "boxplot"))

NULL