neuralnet-master_neuralnetR_源码

calculate.neuralnet <- function (data, model.list, hidden, stepmax, rep, threshold, learningrate.limit, learningrate.factor, lifesign, covariate, response, lifesign.step, startweights, algorithm, act.fct, act.deriv.fct, err.fct, err.deriv.fct, linear.output, likelihood, exclude, constant.weights, learningrate.bp) { time.start.local <- Sys.time() result <- generate.startweights(model.list, hidden, startweights, rep, exclude, constant.weights) weights <- result$weights exclude <- result$exclude nrow.weights <- sapply(weights, nrow) ncol.weights <- sapply(weights, ncol) result <- rprop(weights = weights, threshold = threshold, response = response, covariate = covariate, learningrate.limit = learningrate.limit, learningrate.factor = learningrate.factor, stepmax = stepmax, lifesign = lifesign, lifesign.step = lifesign.step, act.fct = act.fct, act.deriv.fct = act.deriv.fct, err.fct = err.fct, err.deriv.fct = err.deriv.fct, algorithm = algorithm, linear.output = linear.output, exclude = exclude, learningrate.bp = learningrate.bp) startweights <- weights weights <- result$weights step <- result$step reached.threshold <- result$reached.threshold net.result <- result$net.result error <- sum(err.fct(net.result, response)) if (is.na(error) & attr(err.fct, "type") == "ce") if (all(net.result <= 1, net.result >= 0)) error <- sum(err.fct(net.result, response), na.rm = T) if (!is.null(constant.weights) && any(constant.weights != 0)) exclude <- exclude[-which(constant.weights != 0)] if (length(exclude) == 0) exclude <- NULL aic <- NULL bic <- NULL if (likelihood) { synapse.count <- length(unlist(weights)) - length(exclude) aic <- 2 * error + (2 * synapse.count) bic <- 2 * error + log(nrow(response)) * synapse.count } if (is.na(error)) warning("'err.fct' does not fit 'data' or 'act.fct'", call. = F) if (lifesign != "none") { if (reached.threshold <= threshold) { message(rep(" ", (max(nchar(stepmax), nchar("stepmax")) - nchar(step))), step, appendLF = FALSE) message("\terror: ", round(error, 5), rep(" ", 6 - (nchar(round(error, 5)) - nchar(round(error, 0)))), appendLF = FALSE) if (!is.null(aic)) { message("\taic: ", round(aic, 5), rep(" ", 6 - (nchar(round(aic, 5)) - nchar(round(aic, 0)))), appendLF = FALSE) } if (!is.null(bic)) { message("\tbic: ", round(bic, 5), rep(" ", 6 - (nchar(round(bic, 5)) - nchar(round(bic, 0)))), appendLF = FALSE) } time <- difftime(Sys.time(), time.start.local) message("\ttime: ", round(time, 2), " ", attr(time, "units")) } } if (reached.threshold > threshold) return(result = list(output.vector = NULL, weights = NULL)) output.vector <- c(error = error, reached.threshold = reached.threshold, steps = step) if (!is.null(aic)) { output.vector <- c(output.vector, aic = aic) } if (!is.null(bic)) { output.vector <- c(output.vector, bic = bic) } for (w in 1:length(weights)) output.vector <- c(output.vector, as.vector(weights[[w]])) generalized.weights <- calculate.generalized.weights(weights, neuron.deriv = result$neuron.deriv, net.result = net.result) startweights <- unlist(startweights) weights <- unlist(weights) if (!is.null(exclude)) { startweights[exclude] <- NA weights[exclude] <- NA } startweights <- relist(startweights, nrow.weights, ncol.weights) weights <- relist(weights, nrow.weights, ncol.weights) return(list(generalized.weights = generalized.weights, weights = weights, startweights = startweights, net.result = result$net.result, output.vector = output.vector)) } generate.startweights <- function (model.list, hidden, startweights, rep, exclude, constant.weights) { input.count <- length(model.list$variables) output.count <- length(model.list$response) if (!(length(hidden) == 1 && hidden == 0)) { length.weights <- length(hidden) + 1 nrow.weights <- array(0, dim = c(length.weights)) ncol.weights <- array(0, dim = c(length.weights)) nrow.weights[1] <- (input.count + 1) ncol.weights[1] <- hidden[1] if (length(hidden) > 1) for (i in 2:length(hidden)) { nrow.weights[i] <- hidden[i - 1] + 1 ncol.weights[i] <- hidden[i] } nrow.weights[length.weights] <- hidden[length.weights - 1] + 1 ncol.weights[length.weights] <- output.count } else { length.weights <- 1 nrow.weights <- array((input.count + 1), dim = c(1)) ncol.weights <- array(output.count, dim = c(1)) } length <- sum(ncol.weights * nrow.weights) vector <- rep(0, length) if (!is.null(exclude)) { if (is.matrix(exclude)) { exclude <- matrix(as.integer(exclude), ncol = ncol(exclude), nrow = nrow(exclude)) if (nrow(exclude) >= length || ncol(exclude) != 3) stop("'exclude' has wrong dimensions", call. = FALSE) if (any(exclude < 1)) stop("'exclude' contains at least one invalid weight", call. = FALSE) temp <- relist(vector, nrow.weights, ncol.weights) for (i in 1:nrow(exclude)) { if (exclude[i, 1] > length.weights || exclude[i, 2] > nrow.weights[exclude[i, 1]] || exclude[i, 3] > ncol.weights[exclude[i, 1]]) stop("'exclude' contains at least one invalid weight", call. = FALSE) temp[[exclude[i, 1]]][exclude[i, 2], exclude[i, 3]] <- 1 } exclude <- which(unlist(temp) == 1) } else if (is.vector(exclude)) { exclude <- as.integer(exclude) if (max(exclude) > length || min(exclude) < 1) { stop("'exclude' contains at least one invalid weight", call. = FALSE) } } else { stop("'exclude' must be a vector or matrix", call. = FALSE) } if (length(exclude) >= length) stop("all weights are exluded", call. = FALSE) } length <- length - length(exclude) if (!is.null(exclude)) { if (is.null(startweights) || length(startweights) < (length * rep)) vector[-exclude] <- stats::rnorm(length) else vector[-exclude] <- startweights[((rep - 1) * length + 1):(length * rep)] } else { if (is.null(startweights) || length(startweights) < (length * rep)) vector <- stats::rnorm(length) else vector <- startweights[((rep - 1) * length + 1):(length * rep)] } if (!is.null(exclude) && !is.null(constant.weights)) { if (length(exclude) < length(constant.weights)) stop("constant.weights contains more weights than exclude", call. = FALSE)