R/r.diff.R

In alemiani/explora: Explore and Visualize Data

r.diff <- function(dataset, group) {


  ################################################################## create groups
  if(is.factor(group)) {
    gg <- levels(as.factor(group))
    lev <- (as.numeric(as.factor(group)))
    name.g.1 <- paste(substitute(gg))[[1]]
    name.g.2 <- paste(substitute(gg))[[2]]
  } else {
    low.factor  <- paste('low.', substitute(group), sep = '')[[3]]
    high.factor <- paste('High.', substitute(group), sep = '')[[3]]
    name <- NA
    name[group < median(group, na.rm = T)] <- low.factor
    name[group > median(group, na.rm = T)] <- high.factor
    group <- as.factor(name)
    name.g.1 <- high.factor
    name.g.2 <- low.factor
  }
  ##################################################################.
  ##################################################################.
  ## Correlation matrix with p-values. See http://goo.gl/nahmV for documentation of this function
  cor.prob <- function (X, dfr = nrow(X) - 2) {
    R <- cor(X, use="pairwise.complete.obs") # ORIGINAL
    above <- row(R) < col(R)
    r2 <- R[above]^2
    Fstat <- r2 * dfr/(1 - r2)
    R[above] <- 1 - pf(Fstat, 1, dfr)
    R[row(R) == col(R)] <- NA
    R
  }
  ## Use this to dump the cor.prob output to a 4 column matrix
  ## with row/column indices, correlation, and p-value.
  ## See StackOverflow question: http://goo.gl/fCUcQ
  flattenSquareMatrix <- function(m) {
    if( (class(m) != "matrix") | (nrow(m) != ncol(m))) stop("Must be a square matrix.")
    if(!identical(rownames(m), colnames(m))) stop("Row and column names must be equal.")
    ut <- upper.tri(m)
    data.frame(i = rownames(m)[row(m)[ut]],
               j = rownames(m)[col(m)[ut]],
               cor=t(m)[ut],
               p=m[ut])
  }
  ##################################################################.
  ##################################################################.

  data.g1 <- subset(dataset, group == name.g.1)
  nums <- sapply(data.g1, is.numeric)
  H <- data.g1[ , nums]
  mat.dat <- (H)
  cor.df <- flattenSquareMatrix (cor.prob(mat.dat))
  cor.df.1 <- cor.df[order(-abs(cor.df$cor)),]

  data.g2 <- subset(dataset, group == name.g.2)
  nums <- sapply(data.g2, is.numeric)
  H <- data.g2[ , nums]
  mat.dat <- (H)
  cor.df <- flattenSquareMatrix (cor.prob(mat.dat))
  cor.df.2 <- cor.df[order(-abs(cor.df$cor)),]

  data <- dataset
  nums <- sapply(data, is.numeric)
  H <- data[ , nums]
  mat.dat <- (H)
  cor.df <- flattenSquareMatrix (cor.prob(mat.dat))
  cor.df.all <- cor.df[order(-abs(cor.df$cor)),]

  x <- merge(cor.df.1, cor.df.2, by = c('i', 'j'))

  d <- list()
  for(i in 1:(dim(x)[1])) {
    d[i] <- diff(range(x$cor.x[i], x$cor.y[i]))
  }
  x$cor.diff <- unlist(d)

  x$both_sig <- ifelse(
    x$p.x < .07 & x$p.y < .07, 'YES', '-'
  )

  y <- merge(x, cor.df.all, by = c('i', 'j'))
  x <- y[order(-abs(y$cor.diff)),]

  ################## plot
  Title <- paste(name.g.1, 'vs' ,name.g.2, sep = ' ')
  hd <-40
  X10 <- head(x, hd)
  ylim <- c(min(c(X10$cor.x, X10$cor.y)), max(c(X10$cor.x, X10$cor.y)))

  par(mar=c(12, 4, 2, 2) + 0.1)
  plot(X10$cor.diff, ylim = ylim, pch = '', las=3, xaxt = "n", xlab = '', ylab = '')
  grid(nx = dim(X10)[1], ny = NA, lwd = 2)
  title(Title, line = -2)
  abline(h=0)
  segments(1:dim(X10)[1], X10$cor.x, 1:dim(X10)[1], X10$cor.y);
  labels <- paste(X10$i, X10$j, sep = ' ~ ')
  axis(1, at = 1:length(labels),labels = labels,las=3)
  par(mar=c(5.1, 4.1, 4.1, 2.1))
  ################## plot



  x$p.x <- symnum(x$p.x,legend = F, corr = FALSE, na = FALSE,
                  cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("***", "**", "*", ".", " "))
  x$p.y <- symnum(x$p.y,legend = F, corr = FALSE, na = FALSE,
                  cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("***", "**", "*", ".", " "))
  x$p <- symnum(x$p,legend = F, corr = FALSE, na = FALSE,
                cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("***", "**", "*", ".", " "))

  x$cor.x <- round(x$cor.x, 3)
  x$cor.y <- round(x$cor.y, 3)
  x$cor <- round(x$cor, 3)
  x$cor.diff <- round(x$cor.diff, 3)

  x <- x[order(-abs(x$cor)),]

  # if(missing(sort_by) || sort_by == 'r.all') {
  #   x <- x[order(-abs(x$cor)),]
  # } else {
  #   x <- x[order(-abs(x$cor.diff)),]
  # }

  r.g1 <- paste('r_', name.g.1, sep = '')
  p.g1 <- paste('p_', name.g.1, sep = '')
  r.g2 <- paste('r_', name.g.2, sep = '')
  p.g2 <- paste('p_', name.g.2, sep = '')

  names(x)[names(x) == 'cor.x'] <- r.g1
  names(x)[names(x) == 'p.x']   <- p.g1
  names(x)[names(x) == 'cor.y'] <- r.g2
  names(x)[names(x) == 'p.y']   <- p.g2
  names(x)[names(x) == 'cor']   <- 'r.all'


  ##################
  ################## output for X.see
  rowname <- rownames(x)
  i <- ((x[,1]))
  j <- ((x[,2]))
  g <- paste(substitute(group)[3])
  d <- paste(substitute(dataset))

  df <- data.frame(
    Rnum = rowname,
    # dataset    = rep(substitute(dataset), length(rowname)),
    i = i,
    j = j
    # X.group = g
  )
  df$group <- g
  df$dataset <- d
  # print(df)

  X <<- list(x,df)
  View(X[[1]])
  return(X[[1]])


}
# mtcars$vs.F <- as.factor(mtcars$vs)
# r.diff(mtcars, mtcars$vs.F)



see <- function(n, g = TRUE) {
  X[[2]][1]$Rnum <- as.numeric(as.character(X[[2]][1]$Rnum))
  rn <- match(n, X[[2]][1]$Rnum)
  dataset <- X[[2]][5]$dataset[rn]
  group <- X[[2]][4]$group[rn]
  arg1 <- (X[[2]][2]$i[rn])
  arg2 <- (X[[2]][3]$j[rn])
  N.arg.1 <- (which(names(get(dataset))==arg1))
  N.arg.2 <- (which(names(get(dataset))==arg2))
  N.Group <- (which(names(get(dataset))==group))
  Name.arg.1 <- colnames(get(dataset)[N.arg.1])
  Name.arg.2 <- colnames(get(dataset)[N.arg.2])
  Title <- paste(Name.arg.1, "~", Name.arg.2)

  if(g==TRUE) {
    arguments <- list(get(dataset)[, N.arg.1],
                      get(dataset)[, N.arg.2],
                      get(dataset)[, N.Group])
  } else {
    arguments <- list(get(dataset)[, N.arg.1],
                      get(dataset)[, N.arg.2])

  }
  do.call(what = plottest, args = arguments)
  title(Title, col.main="red", line = 0)
}
# see(33,g = T)
# see(33,g = F)
# 22   mtcars$drat,mtcars$wt mtcars$vs


# ttt <- function(formula, data) {
#   cl <- match.call()
#   print(cl) # print call
#   mf <- match.call(expand.dots = FALSE)
#   # print(mf) # print call
#   m <- match(c("formula", 'data'), names(mf), 0L)
#   # print(m)
#   mf <- mf[c(1L, m)]
#   # print(mf)
#   mf$drop.unused.levels <- TRUE
#   mf[[1L]] <- quote(stats::model.frame)
#   # print(mf[[1L]])
#   mf <- eval(mf, parent.frame())
#   # mf
#   print(t.test(mf[,1] ~ mf[,2]))
#   print(names(mf[1]))
#   print(names(mf[2]))
#   prova <<- as.character('ksjdh')
# }; ttt(mtcars$mpg ~ mtcars$vs)
# ttt(mpg ~ vs, mtcars)
# ttt(mtcars$mpg[mtcars$vs == 0], mtcars$mpg[mtcars$vs == 1])