search

r-lib / devtools

Tools to make an R developer's life easier
https://devtools.r-lib.org
Other
2.4k stars 758 forks source link

VDiffr check fails with devtools::check but not with devtools::test, vdiffr::manage_cases or R CMD check #2258

Closed DunLug closed 4 years ago

DunLug commented 4 years ago

Hi, I got some an issue when I try to check my package using devtools::check. This command do unit tests where a check for a plot function is done. Unfortunately, this test systematically fails considering that plots diverge with the saved one. When I check with other methods there is no issue.

My code is :

rythms.df <-data.frame(Action='Movement',
                     RRMethod='interpeak',
                     Prefiltrage='norm_integ',
                     Algorithm='EVM',
                     Postfiltrage='none',
                     rPPG=1:10,
                     PPG=1:10) %>%
    rbind(data.frame(Action='Movement',
                     RRMethod='interpeak',
                     Prefiltrage='norm_m_std',
                     Algorithm='Chrom',
                     Postfiltrage='none',
                     rPPG=1:10,
                     PPG=2*(1:10))) %>%
    rbind(data.frame(Action='Movement',
                     RRMethod='nbpeak',
                     Prefiltrage='norm_integ',
                     Algorithm='EVM',
                     Postfiltrage='none',
                     rPPG=1:10,
                     PPG=rep(1, 10))) %>%
    rbind(data.frame(Action='Movement',
                     RRMethod='nbpeak',
                     Prefiltrage='norm_m_std',
                     Algorithm='Chrom',
                     Postfiltrage='none',
                     rPPG=1:10,
                     PPG=rep(c(1,2), 5))) %>%
    rbind(data.frame(Action='Respiration',
                     RRMethod='interpeak',
                     Prefiltrage='norm_integ',
                     Algorithm='EVM',
                     Postfiltrage='none',
                     rPPG=rep(1, 10),
                     PPG=rep(c(1, 2), 5))) %>%
    rbind(data.frame(Action='Respiration',
                     RRMethod='interpeak',
                     Prefiltrage='norm_m_std',
                     Algorithm='Chrom',
                     Postfiltrage='none',
                     rPPG=c(1, 3, 5, 7, 9),
                     PPG=c(2, 4, 6, 8, 10))) %>%
    rbind(data.frame(Action='Respiration',
                     RRMethod='nbpeak',
                     Prefiltrage='norm_integ',
                     Algorithm='EVM',
                     Postfiltrage='none',
                     rPPG=1:10,
                     PPG=2:11)) %>%
    rbind(data.frame(Action='Respiration',
                     RRMethod='nbpeak',
                     Prefiltrage='norm_m_std',
                     Algorithm='Chrom',
                     Postfiltrage='none',
                     rPPG=1:10,
                     PPG=0:9))

testthat::test_that('rythms.plot.bland_altman', {
    p <- rythms.plot.bland_altman(rythms.df, wrap=vars(Algorithm, RRMethod))
    vdiffr::expect_doppelganger('Rythms bland altman global', function() {print(p)})

    p <- rythms.plot.bland_altman(rythms.df, Action='Respiration', wrap=vars(Algorithm, RRMethod))
    vdiffr::expect_doppelganger('Rythms bland altman Respiration', function() {print(p)})
})

.latex2expr <- function(latex_string)
{
    latex_string %>%
        str_replace_all('\\$([^\\$]*)_\\{([^\\$]*)\\}\\$', '$\\1[\\2]$') %>%
        str_replace_all('\\$([^\\$]*)_([^\\$])([^\\$]*)\\$', '$\\1[\\2]\\3$') %>%
        str_remove_all('\\$') %>%
        str_replace_all(' ', '~')
}

#' @import dplyr
#' @importFrom rlang .data
.compute_local_mae_ba <- function(rythm,
                                  rythms.df,
                                  half_win)
{

    rythms.df %>%
        filter(abs(.data$mean - rythm) < half_win) %>%
        summarise_at(vars(.data$AE), mean) %>%
        pull(.data$AE)
}

#' @import magrittr
#' @importFrom rlang .data
#' @importFrom stats sd
.plot.ba <- function(rythms.df, vars, m, pointsize, latexTitle=FALSE, wrap=vars(.data$Algorithm))
{
    txt_size <- 3
    x_offset <- -5
    y_margin <- 1.1
    ba <- ggplot(rythms.df, aes(x=.data$mean, y=.data$diff))
    # Utile ?
    ba <- ba + geom_hline(data=~group_by_at(rythms.df, wrap) %>%
                              summarise_at(vars(.data$diff), list(m=mean, s=sd)),
                          aes(yintercept=.data$m),
                          color='blue')
    ba <- ba + geom_label(data=~group_by_at(rythms.df, wrap) %>%
                             summarise_at(vars(.data$diff), list(m=mean)),
                         colour='blue', size=txt_size, family='Helvetica',
                         label.padding=unit(0.15, 'lines'),
                         aes(y=.data$m, x=x_offset,
                             vjust=0.5, hjust=0,
                             label=ifelse(.data$m > 0,
                                          paste0('+', round(.data$m, 2)),
                                          round(.data$m, 2))))
    rythms.df %>%
        group_by_at(wrap) %>%
        summarise_at(vars(diff), list(m=mean, s=sd)) %>%
        mutate(h=.data$m+1.96*.data$s, l=.data$m-1.96*.data$s) %>%
        tidyr::gather(key='t', value='v', .data$h:.data$l) -> mstd
    ba <- ba + geom_hline(data=mstd,
                          aes(yintercept=.data$v), color='red')
    ba <- ba + geom_label(data=~mstd %>% mutate(sign = ifelse(.data$t=='h', '+', '-')),
                         colour='red', size=txt_size, label.padding=unit(0.15, 'lines'),
                         aes(y=.data$v, x=x_offset,
                             vjust=ifelse(.data$t=='h', -0.2, 1.2), hjust=0, family='Helvetica',
                             label=ifelse(.data$v > 0,
                                          paste0('+', round(.data$v, 2)),
                                          round(.data$v, 2))))
    half_win <- 1
    maxppg <- max(rythms.df$mean)
    minppg <- min(rythms.df$mean)
    rythms.df %<>% mutate(AE=abs(.data$diff))
    if (maxppg - minppg - 2*half_win > 0.1)
    {
        R <- seq(minppg+half_win, maxppg-half_win, by = 0.1)
        MAEs <- data.frame(rythm = R)

        MAEs$MAE = pmap_dbl(MAEs, .compute_local_mae_ba,
                            rythms.df=rythms.df, half_win=half_win)
        ba <- ba + geom_ribbon(data=MAEs, alpha=0.4, fill='red',
                               mapping=aes(x=.data$rythm, ymin=-.data$MAE,
                                           ymax=.data$MAE, y=NULL))
    }

    ba <- ba + geom_point(size=pointsize)
    title <- unite(vars, col='out', sep='\n')$out
    if (latexTitle) {
        ba <- ba + labs(title=latex2exp::TeX(title),
                    x=latex2exp::TeX('Mean(RR_{ref}, rPPG RR) \\[rpm\\]'),
                    y=latex2exp::TeX('rPPG RR - RR_{ref} \\[rpm\\]'))
    } else {
        ba <- ba + labs(title=title,
                        x='Mean(GT RR, rPPG RR) [rpm]',
                        y='rPPG RR - GT RR [rpm]')
    }
    mstd %<>% ungroup()
    lines_y <- max(abs(mstd$v))
    ylimit <- y_margin * max(m, lines_y)
    xlow <- min(x_offset, min(rythms.df$mean))
    xhigh <- max(rythms.df$mean)
    if (2*ylimit > xhigh - xlow)
    {
        center <- (xhigh + xlow)/2
        xlow <- center - ylimit
        xhigh <- center + ylimit
    } else {
        ylimit <- (xhigh-xlow)/2
    }
    ba <- ba + scale_y_continuous(limits=c(-ylimit, ylimit))
    ba <- ba + coord_fixed(xlim=c(xlow, xhigh), ylim=c(-ylimit, ylimit))

    mean.max <- max(rythms.df$mean)
    ba <- ba + theme(axis.title = element_text(size=9, family = 'Helvetica'),
                     plot.title = element_text(size=9, family='Helvetica'),
                     axis.text = element_text(size=9, family='Helvetica'))
    p <- ggMarginal(ba, type='density', size=10, fill='red', alpha=0.3, color='#00000000', margins='y')
    p
}

rythms.plot.bland_altman <- function(rythms.df, Action='Global',
                                     wrap=vars(.data$Algorithm),
                                     latexTitle=FALSE, nrow=2, ncol=2,
                                     pointsize=0.001)
{
    if (Action != 'Global')
    {
        rythms.df %<>% filter(.data$Action == !!enquo(Action));
    }
    rythms.df %<>% mutate(diff = .data$rPPG - .data$PPG,
                          mean=(.data$rPPG + .data$PPG) / 2)

    m <- max(abs(rythms.df$diff))

    rythms.df %<>% group_by_at(wrap)
    p <- group_map(rythms.df, .plot.ba, .keep=TRUE,
                   pointsize=pointsize, m=m,
                   latexTitle=latexTitle, wrap=wrap)
    p <- plot_grid(plotlist=p, ncol=ncol, nrow=nrow, align='hv')
    p <- p + labs(title=paste0('Bland Altman plot (', Action, ')'))
    p
}

After some tests, it seems that the line that produce errors is the ggMarginal at the end of rythms.plot.bland_altman. However I don't know why it appears only with devtools::check calls.

My setup is : R : 3.6.1 vdiffr: 0.3.2.2 devtools: 2.3.1 ggExtra 0.9 ggplot2: 3.3.2

hadley commented 4 years ago

In the bulk of cases where we're seen failures only in R CMD check it's because of some subtle bug in your code. Unfortunately debugging this is super painful, and we don't have any great advice currently, but we are starting to accumulate a list of "usual suspects" at https://github.com/hadley/r-pkgs/issues/483.