工作脚本

Question

我有两个相同的R脚本;但是，当我运行每个时，一个工作，但另一个抛出错误。我在运行它们之前在不同的R会话中运行每个会话并清除内存。

我无法找到答案，为什么会出现这种情况。

也许其他人遇到过这个问题而且知道它为什么会发生？

工作脚本

library(investr)
library(mgcv) 
library(rootSolve)
library(scam)

inv.predict2 <- function(object, y, x.name, interval = FALSE, 
                     lower, upper, level = 0.95,...) {
.fun1 <- function(x) {
    predFit(object, newdata = setNames(data.frame(x), x.name)) - y
}
.fun2 <- function(x) {
   predFit(object, newdata = setNames(data.frame(x), x.name), 
   interval = "confidence")[, "upr"] - y
   }
.fun3 <- function(x) {
   predFit(object, newdata = setNames(data.frame(x), x.name), 
        interval = "confidence")[, "lwr"] - y
 }
 x0.est <- uniroot.all(lower = lower, upper = upper, ..., f = .fun1)
      res <- if (interval) {
          lwr <- uniroot.all(lower = lower, upper = x0.est, ..., f = .fun2)
          upr <- uniroot.all(lower = x0.est, upper = upper, ..., f = .fun3)
          lwr <- min(c(lwr, upr))
          upr <- max(c(lwr, upr))
c("estimate" = x0.est, "lower" = lwr, "upper" = upr)
} else {
x0.est
}
res
}

predFit.gam <- function(object, newdata, type = c("link", "response"), 
                    interval = c("none", "confidence", "prediction"), 
                    level = 0.95, ...) {
type <- match.arg(type)
interval <- match.arg(interval)
res <- if (interval == "none") {
predict.gam(object, newdata = newdata, type = type, ...)
} else if (interval == "confidence") {
pred <- predict.gam(object, newdata = newdata, se.fit = TRUE, type = "link", 
                ...)
out <- cbind("fit" = pred$fit,
             "lwr" = pred$fit - pred$se.fit * stats::qnorm((level + 1) / 2),
             "upr" = pred$fit + pred$se.fit * stats::qnorm((level + 1) / 2))
if (type == "response") {
  out <- apply(out, MARGIN = 2, FUN = function(x) {
    stats::family(object)$linkinv(x)
  })
}
out
} else {
stop("Prediction intervals are currently not supported for GAMs.")
}
res
}

predFit.scam <- function(object, newdata, type = c("link", "response"), 
                    interval = c("none", "confidence", "prediction"), 
                    level = 0.95, ...) {
    type <- match.arg(type)
    interval <- match.arg(interval)
    res <- if (interval == "none") {
predict.scam(object, newdata = newdata, type = type, ...)
} else if (interval == "confidence") {
pred <- predict.scam(object, newdata = newdata, se.fit = TRUE, type = "link", 
                ...)
out <- cbind("fit" = pred$fit,
             "lwr" = pred$fit - pred$se.fit * stats::qnorm((level + 1) / 2),
             "upr" = pred$fit + pred$se.fit * stats::qnorm((level + 1) / 2))
if (type == "response") {
  out <- apply(out, MARGIN = 2, FUN = function(x) {
    stats::family(object)$linkinv(x)
  })
}
out
} else {
stop("Prediction intervals are currently not supported for SCAMs.")
}
res
}


ptm <- proc.time() 

set.seed(1)

# Rprof()

K <- 1 
N <- 100 
Hstar <- 10

perms <- 10000 

specs <- 1:N 

pop <- array(dim = c(c(perms, N), K))

haps <- as.character(1:Hstar)

probs <- rep(1/Hstar, Hstar) 

x <- c(1:3)
y <- c(3:5)

for(j in 1:perms){
    for(i in 1:K){
        if(i == 1){
        pop[j, specs, i] <- sample(haps, size = N, replace = TRUE, prob = probs)
    }
        else{
            pop[j ,, 1] <- sample(haps[x], size = N, replace = TRUE, prob = probs[x])
            pop[j ,, 2] <- sample(haps[y], size = N, replace = TRUE, prob = probs[y])
        }
}
}

HAC.mat <- array(dim = c(c(perms, N), K))

for(k in specs){
    for(j in 1:perms){
        for(i in 1:K){
            ind.index <- sample(specs, size = k, replace = FALSE)
            hap.plot <- pop[sample(1:nrow(pop), size = 1, replace = TRUE), ind.index, sample(1:K, size = 1, replace = TRUE)] 
            HAC.mat[j, k, i] <- length(unique(hap.plot))
    }
}
}

means <- apply(HAC.mat, MARGIN = 2, mean)
lower <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.025))
upper <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.975))

par(mfrow = c(1, 2))

plot(specs, means, type = "n", xlab = "Specimens sampled", ylab = "Unique haplotypes", ylim = c(1, Hstar))
polygon(x = c(specs, rev(specs)), y = c(lower, rev(upper)), col = "gray")
lines(specs, means, lwd = 2)
HAC.bar <- barplot(N*probs, xlab = "Unique haplotypes", ylab = "Specimens sampled", names.arg = 1:Hstar)

# summaryRprof()

proc.time() - ptm

d <- data.frame(specs, means)

HAC.tp <- gam(means ~ s(specs, bs = "tp", k = 20), optimizer = c("outer", "bfgs"), data = d) # thin plate spline

HAC.tp <- inv.predict2(HAC.tp, y = Hstar, x.name = "specs", interval = TRUE, lower = 1, upper = 1000000)
HAC.tp

非工作脚本

library(investr) 
library(mgcv) 
library(rootSolve)
library(scam) 

inv.predict2 <- function(object, y, x.name, interval = FALSE, 
                     lower, upper, level = 0.95,...) {
.fun1 <- function(x) {
predFit(object, newdata = setNames(data.frame(x), x.name)) - y
}
.fun2 <- function(x) {
predFit(object, newdata = setNames(data.frame(x), x.name), 
        interval = "confidence")[, "upr"] - y
}
.fun3 <- function(x) {
predFit(object, newdata = setNames(data.frame(x), x.name), 
        interval = "confidence")[, "lwr"] - y
}
x0.est <- uniroot.all(lower = lower, upper = upper, ..., f = .fun1)
res <- if (interval) {
lwr <- uniroot.all(lower = lower, upper = x0.est, ..., f = .fun2)
upr <- uniroot(lower = x0.est, upper = upper, ..., f = .fun3)
lwr <- min(c(lwr, upr))
upr <- max(c(lwr, upr))
c("estimate" = x0.est, "lower" = lwr, "upper" = upr)
} else {
x0.est
}
res
}

predFit.gam <- function(object, newdata, type = c("link", "response"), 
                    interval = c("none", "confidence", "prediction"), 
                    level = 0.95, ...) {
type <- match.arg(type)
interval <- match.arg(interval)
res <- if (interval == "none") {
predict.gam(object, newdata = newdata, type = type, ...)
} else if (interval == "confidence") {
pred <- predict.gam(object, newdata = newdata, se.fit = TRUE, type = "link", 
                ...)
out <- cbind("fit" = pred$fit,
             "lwr" = pred$fit - pred$se.fit * stats::qnorm((level + 1) / 2),
             "upr" = pred$fit + pred$se.fit * stats::qnorm((level + 1) / 2))
if (type == "response") {
  out <- apply(out, MARGIN = 2, FUN = function(x) {
    stats::family(object)$linkinv(x)
  })
}
out
} else {
stop("Prediction intervals are currently not supported for GAMs.")
}
res
}

predFit.scam <- function(object, newdata, type = c("link", "response"), 
                    interval = c("none", "confidence", "prediction"), 
                    level = 0.95, ...) {
    type <- match.arg(type)
    interval <- match.arg(interval)
    res <- if (interval == "none") {
predict.scam(object, newdata = newdata, type = type, ...)
} else if (interval == "confidence") {
pred <- predict.scam(object, newdata = newdata, se.fit = TRUE, type = "link", 
                ...)
out <- cbind("fit" = pred$fit,
             "lwr" = pred$fit - pred$se.fit * stats::qnorm((level + 1) / 2),
             "upr" = pred$fit + pred$se.fit * stats::qnorm((level + 1) / 2))
if (type == "response") {
  out <- apply(out, MARGIN = 2, FUN = function(x) {
    stats::family(object)$linkinv(x)
  })
}
out
} else {
stop("Prediction intervals are currently not supported for SCAMs.")
}
res
}

ptm <- proc.time() 

set.seed(1)

# Rprof()

K <- 1 

N <- 100 

Hstar <- 10

perms <- 10000

specs <- 1:N 

pop <- array(dim = c(c(perms, N), K))

haps <- as.character(1:Hstar)

probs <- rep(1/Hstar, Hstar) 

s1 <- c(1:6)

s2 <- c(7:10)

for(j in 1:perms){
    for(i in 1:K){ 
        if(i == 1){
            pop[j, specs, i] <- sample(haps, size = N, replace = TRUE, prob = probs)
    }
        else{
            pop[j ,, 1] <- sample(haps[s1], size = N, replace = TRUE, prob = probs[s1])
            pop[j ,, 2] <- sample(haps[s2], size = N, replace = TRUE, prob = probs[s2])
        }
}
}

HAC.mat <- array(dim = c(c(perms, N), K))

for(k in specs){
    for(j in 1:perms){
        for(i in 1:K){ 
            ind.index <- sample(specs, size = k, replace = FALSE) 
            hap.plot <- pop[sample(1:nrow(pop), size = 1, replace = TRUE), ind.index, sample(1:K, size = 1, replace = TRUE)]
            HAC.mat[j, k, i] <- length(unique(hap.plot)) 
    }
}
}

means <- apply(HAC.mat, MARGIN = 2, mean)
lower <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.025))
upper <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.975))

par(mfrow = c(1, 2))

plot(specs, means, type = "n", xlab = "Specimens sampled", ylab = "Unique haplotypes", ylim = c(1, Hstar))
polygon(x = c(specs, rev(specs)), y = c(lower, rev(upper)), col = "gray")
lines(specs, means, lwd = 2)
HAC.bar <- barplot(N*probs, xlab = "Unique haplotypes", ylab = "Specimens sampled", names.arg = 1:Hstar)

# summaryRprof()

proc.time() - ptm

d <- data.frame(specs, means)

HAC.tp <- gam(means ~ s(specs, bs = "tp", k = 20), optimizer = c("outer", "bfgs"), data = d) # thin plate spline
summary(HAC.tp)
plot(HAC.tp)

HAC.tp <- inv.predict2(HAC.tp, y = Hstar, x.name = "specs", interval = TRUE, lower = 1, upper = 1000000)
HAC.tp

Answer 1

也许尝试其中一个来探索调试功能？

    traceback() 
    browser()

http://adv-r.had.co.nz/Exceptions-Debugging.html

Answer 2

这两个脚本不完全相同。

在第22行，在工作脚本中，您有uniroot.all()，而在非工作脚本中，您有uniroot()。我将非工作更改为uniroot.all()并且完成时没有任何错误（但我完全不知道结果是否正确）。

另外 - 如果它的有用信息，在第102行附近，你在（工作）中有区别：

x <- c(1:3)
y <- c(3:5)

（非工作）：

s1 <- c(1:6)

s2 <- c(7:10)

这种差异可能不太重要，但我想我会告诉你。

最后，对于未来，我建议使用BeyondCompare或Atom。（我想我记得更喜欢Atom，但它已经有一段时间了，因为我们必须在这里使用BC ...）这两个程序（或许多其他类似的替代方案）可以帮助您比较文本（或文件或文件夹）以便轻松找到差异。

两个R脚本具有相同的代码：一个给出结果，另一个抛出错误

工作脚本

非工作脚本

2 个答案: