Question

在回答my previous question @Zheyuan Li时，告诉我如何创建一个函数，该函数返回函数的导数，除非存在其他最优参数。

我想修改该函数以返回渐变。例如，如果我通过此功能：

myfunc <- function(x1, x2, v1){
  e <- exp(0.1*x1+0.2*x2+v1)
  return(e)
}

我想回来

gradient <- c(0.1 * exp(0.1*x1+0.2*x2+v1),
              0.2 * exp(0.1*x1+0.2*x2+v1),
              exp(0.1*x1+0.2*x2+v1))

在x1 == mean(data$x1)，x2==mean(data$x2)，v1==mean(data$v1)评估除非我传递任何这些变量的值。

我认为另一个复杂因素是v1是一个二进制变量，因此该函数应返回在0和1处计算的函数的差值，而不是尝试取导数。 v1是一个指标变量，类似于女性的指标。因此，对于v1采用导数或以均值进行评估是没有意义的。相反，默认值应为v1==0，除非提供了值。

Answer 1

底部是适用于所有连续变量的版本。它可以用于仅涉及连续变量的通用可微函数。这个功能非常有趣和有用，我也可以保留，如果我自己使用的话。除了你给出的功能，我们可以尝试其他（稍微复杂一些）的例子，如：

f1 <- function (x1, x2, x3, x4) x4 * sin(x1) + 2 * x1 * cos(x2) + log(x3) + sqrt(x4)
h(f1, opt = list(x1 = 1.32, x2 = 2.87, x3 = 9.14, x4 = 1.01))

然后它返回：

> h(f1, opt = list(x1 = 1.32, x2 = 2.87, x3 = 9.14, x4 = 1.01))
$loc
  x1   x2   x3   x4 
1.32 2.87 9.14 1.01 

$grad
        x1         x2         x3         x4 
-1.6760325 -0.7082224  0.1094092  1.4662337

在输入时，dat或opt可能会丢失，并且默认为NULL;但是，它们都不能丢失，并且该功能将检查这一点。退出时，它会显示一个列表，其中包含评估渐变的位置$loc，以及渐变值$grad。

示例通话（在前一篇文章中使用OP＆＃39;示例df和myfunc）：

> h(myfunc, df)
$loc
      x1       x2       v1 
1.971663 4.043786 0.540000 

$grad
       x1        x2        v1 
0.4692303 0.9384607 4.6923033

> h(myfunc, df, opt = list(x1 = 1, x2 = 2, v1 = 0))
$loc
x1 x2 v1 
 1  2  0 

 $grad
        x1        x2        v1 
 0.1648721 0.3297443 1.6487213

> h(myfunc, df, opt = list(x1 = 1, x2 = 2))
$loc
      x1   x2   v1 
    1.00 2.00 0.54 

$grad
       x1        x2        v1 
0.2829217 0.5658434 2.8292170

该功能也以健壮的方式编写。例如，传递无关变量并不重要：

> h(myfunc, df, opt = list(x1 = 1, x2 = 2, y = 0.4))
$loc
  x1   x2   v1 
1.00 2.00 0.54 

$grad
       x1        x2        v1 
0.2829217 0.5658434 2.8292170

当变量不完整时，它会抱怨：

> df <- df[-2]   ## drop "x2"
> h(myfunc, df, opt = list(x1 = 0))   ## "x2" also not in opt list
Error in h(myfunc, df, opt = list(x1 = 0)) (from h) : 
  Those variables are not found from `dat` or `opt`: x2

df或opt中变量的顺序不必与FUN中的变量顺序相同。在执行函数期间，它将相应地重新排序变量以与FUN中的变量顺序一致。

h <- function(FUN, dat = NULL, opt = NULL) {
  ## check arguments of h
  if (missing(FUN)) stop("No given function: FUN")
  if (!is.function(FUN)) stop("arguments 'FUN' is not a function!")
  DAT <- !missing(dat)
  if (DAT && !is.data.frame(dat)) stop("arguments 'dat' must be a data frame!")
  OPT <- !is.null(opt); if (OPT && !is.list(opt)) stop("optional arguments must be provided as a list!")
  if (!DAT && !OPT) stop("Neither 'dat' nor 'opt' is provided!")
  ## check variables
  FUN_args <- formalArgs(FUN)  ## get arguments of FUN
  dat_vars <- colnames(dat)  ## get column vars of dat
  dat_vars <- dat_vars[dat_vars %in% FUN_args]
  dat <- dat[dat_vars]
  opt_vars <- names(opt)  ## get names of optional arguments
  if (OPT) {
    opt_vars <- opt_vars[opt_vars %in% FUN_args]
    opt <- opt[opt_vars]
    }
  ## checking whether variables are complete
  missing_vars <- FUN_args[!FUN_args %in% c(dat_vars, opt_vars)]
  if (length(missing_vars)) stop(paste("Those variables are not found from `dat` or `opt`:", paste(missing_vars, collapse = ", ")))
  ## get column mean from "dat" for those vars not in opt_vars
  dat_vars <- dat_vars[!dat_vars %in% opt_vars]
  if (length(dat_vars)) {
    val <- lapply(dat[dat_vars], FUN = mean, na.rm = TRUE)
    opt <- c(val, opt)  ## combine val and opt
    }
  ## convert them into "friendly" character vector
  opt <- unlist(opt[match(FUN_args, names(opt))])
  val <- paste(names(opt), opt, sep = " = ")
  ## now, let's iterate from all arguments of FUN, taking derivatives
  n <- length(FUN_args);
  gradient <- numeric(n); names(gradient) <- names(opt)
  for (i in 1:n) {
    ## prepare function call!
    init <- paste0("numDeriv::grad(FUN, x = ", opt[i])
    expr <- paste(val[-i], collapse = ", ")
    expr <- paste0(paste(init, expr, sep = ", "), ")")
    ## evaluate partial derivatives
    gradient[i] <- eval(parse(text = expr))
    }
  ## return
  list(loc = opt, grad = gradient)
  }

除非存在可选参数，否则计算平均值的梯度？

1 个答案: