In GegznaV/spHelper: Extension of Package `hyperSpec` and Various Convenience Functions

knitr::opts_chunk$set(collapse = FALSE,
                      comment = "#>",
                      fig.align = 'center')
optDEF <- knitr::opts_chunk$get()

Load packages

library(spHelper)
library(spPlot)
library(spMisc)
library(plotly)

qplot_sp, qplot_kSp, and qplot_kSpFacets

knitr::opts_chunk$set(fig.width = 6, fig.align = 'center')

data(flu, package = "hyperSpec")

qplot_sp(flu)
qplot_kSp(flu)
qplot_kSpFacets(flu)

Use facets

qplot_sp(flu, Title = "Flu dataset", facets = TRUE)
qplot_kSpFacets(flu, Title = "Flu dataset")

Plot normalized spectra

qplot_kSpFacets(flu, Title = "Flu dataset", normalize = 1)
qplot_kSpFacets(flu, Title = "Flu dataset", normalize = FALSE)
qplot_kSpFacets(flu, Title = "Flu dataset", normalize = -1)
qplot_sp(flu, Title = "Flu dataset", normalize = 1)

Remove fill

flu$c2 <- as.factor(flu$c)

# `qplot_sp` uses no fill by default
p <- qplot_sp(flu, Title = "Flu dataset", names.in = 'c2')

# Otherwise set parameter `filled = FALSE`
p <- qplot_kSp(flu, Title = "Flu dataset", names.in = 'c2', filled = FALSE)
p

Name of the legend

# No name
qplot_kSp(flu, Title = "Flu dataset", names.in = 'c2', legendName = FALSE)
# Automatic name
qplot_kSp(flu, Title = "Flu dataset", names.in = 'c2', legendName = TRUE)
qplot_kSp(flu, Title = "Flu dataset", names.in = 'c2', legendName = "Concentration")

Examples using package plotly

dsamp <- diamonds[sample(nrow(diamonds), 1000), ]
qplot(carat, price, data = dsamp, colour = clarity) %>% ggplotly()

data(Loadings2)

qplot_kSpFacets(Loadings2)
# ggplotly()

qplot_kAmp and qplot_scores

data(Scores2)

qplot_kAmp(Scores2)
qplot_scores(Scores2)

qplot_kAmp(Scores2, by = "class")

p <- qplot_scores(Scores2, add.jitter = TRUE)
p

p + theme_bw()

qplot_spStat - Plot Summary Statistic of Spactra

qplot_spStat(chondro,"clusters",mean)
qplot_spStat(chondro,"clusters",mean,All = FALSE)
qplot_spStat(chondro,"clusters",mean_sd,All = FALSE) +
    facet_grid(.~clusters) +
    nTick_x()

qplot_spStat(chondro,"clusters",median,All = FALSE, fixed.colors = FALSE)
qplot_spStat(chondro,"clusters",median, "My Title")

qplot_spStat(chondro,"clusters",mean_pm_sd) +
    facet_grid(.~clusters) +
    nTick_x()

Examples with the other dataset

qplot_spStat(Spectra2,"gr",mean)
qplot_spStat(Spectra2,"gr",mean,All = FALSE)
qplot_spStat(Spectra2,"gr",mean_sd,All = FALSE) +
    facet_grid(.~gr) +
    nTick_x()

qplot_spStat(Spectra2,"gr",median,All = FALSE, fixed.colors = FALSE)
qplot_spStat(Spectra2,"gr",median, "My Title")

qplot_spStat(Spectra2,"gr",mean_pm_sd) +
    facet_grid(.~gr) +
    nTick_x()

Function center_subtracted_centers

Function calculates centers (i.e., means, medians) for each indicated group. Then common center (e.g., a center of all data, a balanced center of all data, a center of certain group or a known spectrum) is subtracted from group centers.

In this context, a \emph{center} is a mean, a median or similar statistic, calculated at each wavelangth.

# === Common center of all spectra as the subtracted center ================

CSCs <- center_subtracted_centers(sp = Spectra2, by = "gr")

# ggplot2 type plot --------------------------------------------------------
qplot_sp(CSCs, by = "gr") + ggtitle("CSCs - center subtracted centers")

# R base type plot ---------------------------------------------------------
names <- CSCs$gr
plotspc(CSCs, col = names)
legend("topright", lty = 1, col = names, legend = names, bty = "n")
title("CSCs - center subtracted centers")


# === Center of a certain group as the subtracted center ===================

center_subtracted_centers(Spectra2, "gr", Center = "A")  %>%
    qplot_sp(by = "gr") +
    ggtitle("Subtraced center is center of group 'A'")

center_subtracted_centers(Spectra2, "gr", Center = "C")  %>%
    qplot_sp(names.in = "gr")+
    ggtitle("Subtraced center is center of group 'C'")



# === Balanced center as the subtracted center =============================

center_subtracted_centers(Spectra2, "gr", balanced = TRUE)  %>%
    qplot_sp(names.in = "gr")+
    ggtitle(subt("Balanced center subtraced centers (BCSCs)",
                 "Balanced = a mean of all group centers\n" %++%
                     "Balanced center is mean"))


center_subtracted_centers(Spectra2, "gr",
                          balanced = TRUE,
                          balance.FUN = median)  %>%
    qplot_sp(names.in = "gr") +
    ggtitle(subt("Balanced center subtraced centers (BCSCs)",
                 "Balanced center is median"))


# === Scaled data ==========================================================


MED <- apply(Spectra2,2,median)
MAD <- apply(Spectra2,2,mad)   # median absolute deviation
scale(Spectra2,center = MED, scale = MAD)  %>%
    center_subtracted_centers(by = "gr")  %>%
    qplot_sp(names.in = "gr") +
    ggtitle(subt("CSCs of scaled data","Scaling: x = (x-median)/MAD"))


scale(Spectra2,center = MED, scale = MAD)  %>%
    center_subtracted_centers(by = "gr",
                              balanced = TRUE,
                              balance.FUN = median)  %>%
    qplot_sp(names.in = "gr") +
    ggtitle(subt("Balanced median SCs of scaled data",
                 "Scaling: x = (x-median)/MAD"))

# === Add curves of common & balanced central tendencies =================

center_subtracted_centers(Spectra2, "gr",
                          show.balanced = TRUE,
                          show.all = TRUE)  %>%
    qplot_sp(names.in = "gr") +
    ggtitle(subt("Curves of common & balanced centers added",
                 "Imbalanced center subtracted centers"))


center_subtracted_centers(Spectra2, "gr",
                          balanced = TRUE,
                          show.balanced = TRUE,
                          show.all = TRUE)  %>%
    qplot_sp(names.in = "gr")+
    ggtitle(subt("Curves of common & balanced centers added",
                 "Balanced center subtracted centers"))


center_subtracted_centers(Spectra2, "gr", Center = "C",
                          show.balanced = TRUE,
                          show.all = TRUE)  %>%
    qplot_sp(names.in = "gr")+
    ggtitle(subt("Curves of common & balanced centers added",
                 "Group 'C' center subtracted centers"))

qplot_proximity and qplot_prediction

Examples with a hyperSpec object

 clear()

 data(Scores2)
 Scores2$Prediction <- sample(Scores2$gr)
 Scores2 <- hyAdd_color(sp = Scores2, by = "gr", palette = c("tan3", "green4","skyblue"))

 qplot_prediction(Scores2,Prediction = "Prediction", Reference = "gr")
 qplot_prediction(Scores2,Prediction = "Prediction", Reference = "gr", type = "ref")

 qplot_prediction(Scores2,"Prediction","gr", type.stat = "ref", MDS = "isoMDS")

Taking a smaller number of variables, which are not noise, may lead to better discrimination of groups.

 sc <- Scores2[,,c(1,3),wl.index = TRUE]

 qplot_prediction(sc,"Prediction","gr", type = "reference")
 qplot_prediction(sc,"Prediction","gr", type = "prediction")
 qplot_prediction(sc,"Prediction","gr", type = "prediction", type.stat = "ref")
 qplot_prediction(sc,"Prediction","gr", type = "prediction", type.stat = "ref", stat = "ellipse")

In proximity plots qplot_proximity only one grouping variable is needed:

 set.seed(1)
 sc <- sample(Scores2[,,c(1,2),wl.index = TRUE],50)
 sc <- hyAdd_color(sp = sc , by = "class", palette = c("tan3", "green4","skyblue","violet"))
 ID <- rownames(sc)

 qplot_proximity(sc, "class")

 qplot_proximity(sc, "class",  plot.scatter = FALSE) + geom_text(aes(label = ID))

Plotting extra information

 Clusters <- as.factor(kmeans(sc,3)$cluster)
 qplot_proximity(sc, "class", stat = FALSE) + stat_chull(aes(fill = Clusters), color = NA, alpha = .2)

qplot_crosstab

# Generate data: Random guess  ============================
 N <- 1000 # number of observations

Prediction <- sample(c("A","B","C","D"), N, replace = TRUE)
Reference  <- sample(c("A", "B","C","D","E"),N, replace = TRUE)

tabl <- table(Prediction,Reference)

qplot_crosstab(tabl)
qplot_crosstab_sort(tabl,subTitle = "Columns and rows sorted by the best match")   # different order of columns and rows
qplot_crosstab0(tabl,subTitle = "Without highlighting")    # no colors
qplot_crosstab0s(tabl,subTitle = "Sorted by the best match, no highlighting")   # no colors, different order of columns and rows

qplot_confusion

# knitr::opts_chunk$set(optDEF)
# knitr::opts_chunk$set(fig.width = 5, fig.show = "hold")
knitr::opts_chunk$set(fig.width = 5)

d <- 5 # number of rows/columns
Mat <- matrix(sample(0:100,d ^ 2,T),d)
colnames(Mat) <- paste0("gr",1:d)
rownames(Mat) <- colnames(Mat)
class(Mat)
qplot_confusion(Mat, subTitle = "Input is a matrix (1)")

diag(Mat)[2:3] <- c(1000,250)
qplot_confusion(Mat, subTitle = "Input is a matrix (2)", TPR.name = "<Sensitivity>")

qplot_confusion(Mat, subTitle = "Input is a matrix (3) diagonal values sorted ", sort = "diagonal")

set.seed(165)

N <- 1000 # number of observations

Prediction <- sample(c("A","B","C","D"),N, replace = TRUE)
Reference  <- sample(c("A", "B","C","D"),N, replace = TRUE)


qplot_confusion(Prediction, Reference, subTitle = "Correct by chance (inputs are two vectors)")
# Random guess  =====================
conf <- table(Prediction,Reference)
class(conf)

qplot_confusion(conf, subTitle = "Correct by chance (input is 'table')")

# At least 40% of the cases agree =====================
ind2 <- sample(1:N,round(N*.50))
Reference[ind2] <- Prediction[ind2]
conf2 <- table(Prediction,Reference)

qplot_confusion(conf2, subTitle = "Correct >50%")

# Most of the cases agree =============================
ind3 <- sample(1:N,round(N*.80))
Reference[ind3] <- Prediction[ind3]
conf3 <- table(Prediction,Reference)

qplot_confusion(conf3, subTitle = "Correct >80%")
qplot_confusion(conf3, subTitle = "Correct >80%", metric = "weighted.kappa")
qplot_confusion(conf3, subTitle = "Correct >80%", metric = "meanTPR")

# Sort rows and columns by the best match ============
conf3_sorted <- sort_descOnDiag(conf2)
qplot_confusion(conf3_sorted, subTitle = "Columns and rows sorted by the best match")

# Proportions =========================================

qplot_confusion(conf3              , subTitle = "Counts")
qplot_confusion(prop.table(conf3),   subTitle = "Proportions (total sum = 1)")

# Shades: proportional ================================

qplot_confusion(conf,shades = "prop",  subTitle = "Shades: 'prop', Correct by chance");
qplot_confusion(conf,shades = "max",   subTitle = "Shades: 'max', Correct by chance")

qplot_confusion(conf2,shades = "prop", subTitle = "Shades: 'prop', Correct >50%");
qplot_confusion(conf2,shades = "max",  subTitle = "Shades: 'max', Correct >50%")

qplot_confusion(conf3,shades = "prop", subTitle = "Shades: 'prop', Correct >80%");
qplot_confusion(conf3,shades = "max",  subTitle = "Shades: 'max', Correct >80%")

# Shades: constant and none ===========================

qplot_confusion(conf3,shades = "const",subTitle = "Shades: constant");
qplot_confusion(conf3,shades = "none", subTitle = "Shades: none")

n <- round(N/6)
Prediction[sample(which(Prediction == "A"),n,replace = TRUE)] <-
    sample(c("B","C"), n,replace = TRUE)

conf4 <- table(Prediction,Reference)

qplot_confusion(conf4, subTitle = "Imbalanced class proportions")

infoDim, qplot_infoDim and qplot_screeplot

knitr::opts_chunk$set(fig.width = 6, fig.show = "asis")

# Example 1 =============================================================
my_matrix <- matrix(rexp(2000, rate = .1), ncol = 20)
my_result <- infoDim(my_matrix)

# Investigate the result
str(my_result)
my_result$exactDim
my_result$dim

#Plot
qplot_screeplot(my_result) # Object of class "infoDim"


qplot_screeplot(my_matrix) # Object of class "matrix"
qplot_infoDim(my_matrix)


# Example 2 =============================================================

p1 <- qplot_infoDim(Spectra2) # Object of class "hyperSpec"
p1

# Possition of a legend changes, if theme applied in this way:
p1 + theme_grey()

# A better way to use non-default theme:
p2 <- qplot_infoDim(Spectra2, ggtheme = theme_grey())
p2

# Numbes of selected components can be indicated
p3 <- qplot_infoDim(Spectra2, selected = 4)
p3
# ggplotly(p3)

# Numbes of selected components can be indicated
p4 <- qplot_infoDim(Spectra2, y.log = FALSE)

p4
# ggplotly(p4)

unipeak - Transform Spectra of Components

#  Example 1 -------------------------------------------------------

x     <- seq(-10,20,.1)
y0    <- GaussAmp(x, c = 0, A = 1) + GaussAmp(x, c = 10, A = 2) - .5
y0NEW <- unipeak(y0)

# Plot the results
par(mfrow = c(1,1))
plot( x, y0,    type = "l", lty = 3,
      main = "'unipeak' keeps positive part \n of highest peak only" );
lines(x, y0NEW, type = "l", lty = 1, lwd = 3);
legend("topleft", legend = c("Before","After"), lty = c(3,1))

#  Example 2 -------------------------------------------------------

x  = seq(-10,20,.1)
y1 = (sin(x/4) + GaussAmp(x))
y2 = (2*sin(x) + sin(x/5) + GaussAmp(x, c = 5))
y  = base::rbind(y1,y2)

yNEW <- apply(y,1,unipeak)

par(mfrow = c(3,1))

# plot 1
matplot(x, t(y), type = "l", lty = 3,
        main = "A - Initial curves");
abline(h = 0)

# plot 2
matplot(x,yNEW, type = "l", lty = 1,lwd = 3,
        main = "B - Only the highest positive\n peaks per curve");
abline(h = 0)

# plot 3: both plots together
matplot(x, t(y), type = "l", lty = 3, main = "A and B together");
matlines(x,yNEW, type = "l", lty = 1,lwd = 3);
abline(h = 0)

par(mfrow = c(1,1))

subt - Title and Subtitle

 subt("Cars")
 ## bold("Cars")

 subt("Cars","Distance vs. speed")
 ## atop(bold("Cars"), atop(italic("Distance vs. speed")))

 # ----------------------------------------------------------------

 plot(cars[,1:2], main = "Cars")
 plot(cars[,1:2], main = subt("Cars")) # the same as in previous line
 plot(cars[,1:2], main = subt("Cars","Distance vs. speed"))
 plot(cars[,1:2], main = subt(subTitle = "Distance vs. speed"))

 # ----------------------------------------------------------------

 library(ggplot2)

 g <- qplot(mpg, wt, data = mtcars)
 g + ggtitle("Cars") # non-bold title
 g + ggtitle(subt("Cars")) # bold title
 g + ggtitle(subt("Cars","Distance vs. speed"))
 g + ggtitle(subt(subTitle = "Distance vs. speed"))


 # ----------------------------------------------------------------

 library(lattice)

 xyplot(eruptions~waiting, data = faithful)

 xyplot(eruptions~waiting, data = faithful,
  main = "Old Faithful Geyser Data")

 xyplot(eruptions~waiting, data = faithful,
  main = subt("Old Faithful Geyser Data"))

 xyplot(eruptions~waiting, data = faithful,
  main = subt("Old Faithful Geyser", "Data"))

 xyplot(eruptions~waiting, data = faithful,
  main = subt(subTitle = "Old Faithful Geyser Data"))

GegznaV/spHelper documentation built on April 16, 2023, 1:42 p.m.