diff --git a/learn_lm.R b/learn_lm.R new file mode 100644 index 0000000..852456b --- /dev/null +++ b/learn_lm.R @@ -0,0 +1,77 @@ +learn_ml <- function (formula, data, subset, weights, na.action, method = "qr", + model = TRUE, x = FALSE, y = FALSE, qr = TRUE, singular.ok = TRUE, + contrasts = NULL, offset, ...) { + ret.x <- x + ret.y <- y + cl <- match.call() + mf <- match.call(expand.dots = FALSE) + m <- match(c("formula", "data", "subset", "weights", "na.action", + "offset"), names(mf), 0L) + mf <- mf[c(1L, m)] + mf$drop.unused.levels <- TRUE + mf[[1L]] <- quote(stats::model.frame) + mf <- eval(mf, parent.frame()) + if (method == "model.frame") + return(mf) + else if (method != "qr") + warning(gettextf("method = '%s' is not supported. Using 'qr'", + method), domain = NA) + mt <- attr(mf, "terms") + y <- model.response(mf, "numeric") + w <- as.vector(model.weights(mf)) + if (!is.null(w) && !is.numeric(w)) + stop("'weights' must be a numeric vector") + offset <- model.offset(mf) + mlm <- is.matrix(y) + ny <- if (mlm) + nrow(y) + else length(y) + if (!is.null(offset)) { + if (!mlm) + offset <- as.vector(offset) + if (NROW(offset) != ny) + stop(gettextf("number of offsets is %d, should equal %d (number of observations)", + NROW(offset), ny), domain = NA) + } + if (is.empty.model(mt)) { + x <- NULL + z <- list(coefficients = if (mlm) matrix(NA_real_, 0, + ncol(y)) else numeric(), residuals = y, fitted.values = 0 * + y, weights = w, rank = 0L, df.residual = if (!is.null(w)) sum(w != + 0) else ny) + if (!is.null(offset)) { + z$fitted.values <- offset + z$residuals <- y - offset + } + } + else { + x <- model.matrix(mt, mf, contrasts) + z <- if (is.null(w)) + lm.fit(x, y, offset = offset, singular.ok = singular.ok, + ...) + else lm.wfit(x, y, w, offset = offset, singular.ok = singular.ok, + ...) + } + class(z) <- c(if (mlm) "mlm", "lm") + z$na.action <- attr(mf, "na.action") + z$offset <- offset + z$contrasts <- attr(x, "contrasts") + z$xlevels <- .getXlevels(mt, mf) + z$call <- cl + z$terms <- mt + if (model) + z$model <- mf + if (ret.x) + z$x <- x + if (ret.y) + z$y <- y + if (!qr) + z$qr <- NULL + z +} + +set.seed(123) # 保证随机数可重复 +x <- rnorm(100) +y <- 20 * x + 23 + rnorm(100) + +model <- learn_ml(y ~ x, data = data.frame(x = x, y = y)) \ No newline at end of file diff --git a/mycode/T.R b/mycode/T.R new file mode 100644 index 0000000..972912c --- /dev/null +++ b/mycode/T.R @@ -0,0 +1,70 @@ +lin_reg <- function(formula, data, subset, save_model = TRUE, + weights = NULL, na.action = na.fail, + model_save_path = NULL, ...) { + + mf <- match.call(expand.dots = FALSE) + mf <- mf[c(1L, match(c("formula", "data", "subset", "save_model", "weights", "na.action", "model_save_path"), names(mf), 0L))] + mf$drop.unused.levels <- TRUE + mf[[1L]] <- as.name("model.frame") + mf <- eval(mf, parent.frame()) + + mt <- attr(mf, "terms") + y <- model.response(mf, "numeric") + + if (!is.null(weights)) { + if (!is.numeric(weights)) + stop("'weights' must be a numeric vector") + } + + x <- model.matrix(mt, mf) + + if (is.null(weights)) { + coef <- lm.fit(x, y)$coefficients + } else { + coef <- lm.wfit(x, y, weights)$coefficients + } + + model <- structure(list(coefficients = coef, residuals = y - x %*% coef, + call = match.call(), terms = mt, model = mf, + na.action = attr(mf, "na.action"), + xlevels = .getXlevels(mt, mf)), + class = "lin_reg") + + if (save_model) { + if (is.null(model_save_path)) { + curr_dir <- getwd() + model_save_path <- paste(curr_dir, "linear_model.rda", sep = "/") + } + + # check model_save_path fairness + dir_path <- dirname(model_save_path) + if (!file.exists(dir_path)) { + dir.create(dir_path, recursive = TRUE) + } + + # Check if file already exists, modify filename if needed + base_name <- basename(model_save_path) + pattern <- paste0("^", gsub("[.]", "\\.", base_name), "$") + dir_files <- list.files(dir_path, pattern = pattern, full.names = FALSE) + + i <- 1 + basename_omit <- strsplit(base_name, "\\.")[[1L]][[1L]] + while (base_name %in% dir_files) { + base_name <- paste0(basename_omit, i, ".rda") + i <- i + 1 + } + + model_save_path <- file.path(dir_path, base_name) + print(cat("model will be save in ", model_save_path)) + save(model, file = model_save_path) + } + + model +} + +# 创建一些数据 +x <- rnorm(100) +y <- 20 * x + 23 + rnorm(100) + +# 使用 lin_reg 训练模型 +model <- lin_reg(y ~ x, data = data.frame(x = x, y = y)) \ No newline at end of file diff --git a/mycode/test1.R b/mycode/test1.R new file mode 100644 index 0000000..4a866d5 --- /dev/null +++ b/mycode/test1.R @@ -0,0 +1,30 @@ +if (!requireNamespace("animation")) install.packages("animation") +library(animation) + +# 设置动画参数 +interval <- 20 +ani.options(interval = interval) # 设置帧间隔时间 + +# 动态拟合线性模型 +dynamic_fit <- function(n_points_max = 100, step = 20) { + set.seed(123) # 设置随机种子确保可重复性 + x <- rnorm(n_points_max) + y <- 20 * x + 23 + rnorm(n_points_max) # 生成带有噪声的线性数据 + + saveGIF({ + for (n in seq(step, n_points_max, by = step)) { + # 使用前n个点拟合模型 + model <- lm(y ~ x, data = data.frame(x = x[1:n], y = y[1:n])) + # 预测整个x范围内的y值 + predictions <- predict(model, data.frame(x = seq(min(x), max(x), length.out = 100))) + # 绘制当前拟合线 + plot(x[1:n], y[1:n], pch=19, col="blue", main=paste0("Fitting with ", n, " points"), + xlab = "x", ylab = "y") + lines(seq(min(x), max(x), length.out = 100), predictions, col="red", lwd=2) + + Sys.sleep(interval) # 暂停一下,让动画效果更明显 + } + }, movie.name = "dynamic_fit.gif", interval = 0.1) +} + +dynamic_fit() \ No newline at end of file diff --git a/mypkgs/mylin2024111211/.Rbuildignore b/mypkgs/mylin2024111211/.Rbuildignore new file mode 100644 index 0000000..813f03a --- /dev/null +++ b/mypkgs/mylin2024111211/.Rbuildignore @@ -0,0 +1,2 @@ +^mylin2024111211\.Rproj$ +^\.Rproj\.user$ diff --git a/mypkgs/mylin2024111211/.gitignore b/mypkgs/mylin2024111211/.gitignore new file mode 100644 index 0000000..cd67eac --- /dev/null +++ b/mypkgs/mylin2024111211/.gitignore @@ -0,0 +1 @@ +.Rproj.user diff --git a/mypkgs/mylin2024111211/DESCRIPTION b/mypkgs/mylin2024111211/DESCRIPTION new file mode 100644 index 0000000..825fe46 --- /dev/null +++ b/mypkgs/mylin2024111211/DESCRIPTION @@ -0,0 +1,12 @@ +Package: mylin2024111211 +Title: What the Package Does (One Line, Title Case) +Version: 0.0.0.9000 +Authors@R: + person("First", "Last", , "first.last@example.com", role = c("aut", "cre"), + comment = c(ORCID = "YOUR-ORCID-ID")) +Description: What the package does (one paragraph). +License: `use_mit_license()`, `use_gpl3_license()` or friends to pick a + license +Encoding: UTF-8 +Roxygen: list(markdown = TRUE) +RoxygenNote: 7.3.2 diff --git a/mypkgs/mylin2024111211/NAMESPACE b/mypkgs/mylin2024111211/NAMESPACE new file mode 100644 index 0000000..daad58b --- /dev/null +++ b/mypkgs/mylin2024111211/NAMESPACE @@ -0,0 +1,6 @@ +# Generated by roxygen2: do not edit by hand + +S3method(print,lm) +export(lin_reg) +export(predict) +export(save_model) diff --git a/mypkgs/mylin2024111211/R/lin_reg.R b/mypkgs/mylin2024111211/R/lin_reg.R new file mode 100644 index 0000000..79f417c --- /dev/null +++ b/mypkgs/mylin2024111211/R/lin_reg.R @@ -0,0 +1,77 @@ +#' Linear Regression Model +#' +#' @description train a linear model +#' @param formula describle model formula, such as y ~ x +#' @param data data build from data.frame, such as data.frame(x = x, y = y) +#' @param subset Specify a subset, such as fitting only the portion of +#' data greater than 0 in the dataset. +#' @param save_model whether save model. Default TRUE +#' @param weights Optional vector of case weights. +#' @param na.action Function indicating what should happen when the data contain NAs. +#' default na.fail, optional is [na.omit, ] +#' @param model_save_path User define the model save path. +#' @return return a list consist of coefficiences and formula +#' @export +lin_reg <- function(formula, data, subset, save_model = TRUE, + weights = NULL, na.action = na.fail, + model_save_path = NULL, ...) { + + mf <- match.call(expand.dots = FALSE) + mf <- mf[c(1L, match(c("formula", "data", "subset", "save_model", "weights", "na.action", "model_save_path"), names(mf), 0L))] + mf$drop.unused.levels <- TRUE + mf[[1L]] <- as.name("model.frame") + mf <- eval(mf, parent.frame()) + + mt <- attr(mf, "terms") + y <- model.response(mf, "numeric") + + if (!is.null(weights)) { + if (!is.numeric(weights)) + stop("'weights' must be a numeric vector") + } + + x <- model.matrix(mt, mf) + + if (is.null(weights)) { + coef <- lm.fit(x, y)$coefficients + } else { + coef <- lm.wfit(x, y, weights)$coefficients + } + + model <- structure(list(coefficients = coef, residuals = y - x %*% coef, + call = match.call(), terms = mt, model = mf, + na.action = attr(mf, "na.action"), + xlevels = .getXlevels(mt, mf)), + class = "lin_reg") + + if (save_model) { + if (is.null(model_save_path)) { + curr_dir <- getwd() + model_save_path <- paste(curr_dir, "linear_model.rda", sep = "/") + } + + # check model_save_path fairness + dir_path <- dirname(model_save_path) + if (!file.exists(dir_path)) { + dir.create(dir_path, recursive = TRUE) + } + + # Check if file already exists, modify filename if needed + base_name <- basename(model_save_path) + pattern <- paste0("^", gsub("[.]", "\\.", base_name), "$") + dir_files <- list.files(dir_path, pattern = pattern, full.names = FALSE) + + i <- 1 + basename_omit <- strsplit(base_name, "\\.")[[1L]][[1L]] + while (base_name %in% dir_files) { + base_name <- paste0(basename_omit, i, ".rda") + i <- i + 1 + } + + model_save_path <- file.path(dir_path, base_name) + print(cat("model will be save in ", model_save_path)) + save(model, file = model_save_path) + } + + model +} diff --git a/mypkgs/mylin2024111211/R/predict.R b/mypkgs/mylin2024111211/R/predict.R new file mode 100644 index 0000000..33af18e --- /dev/null +++ b/mypkgs/mylin2024111211/R/predict.R @@ -0,0 +1,19 @@ +#' Predict from a Simple Linear Regression Model +#' +#' Predict new responses given the regression model and new input values. +#' +#' @param object An object of class "mylin". +#' @param newdata A data frame or matrix of new input values. +#' @param ... Additional arguments. +#' @return A vector of predicted values. +#' @export +predict.mylin <- function(object, newdata, ...) { + # Extract the coefficients + coef <- object$coefficients + # Create the model matrix for the new data + mm <- model.frame(object$terms, newdata) + x <- model.matrix(object$terms, mm) + # Compute predictions + predict <- x %*% coef + predict +} \ No newline at end of file diff --git a/mypkgs/mylin2024111211/R/print.R b/mypkgs/mylin2024111211/R/print.R new file mode 100644 index 0000000..e7c3f68 --- /dev/null +++ b/mypkgs/mylin2024111211/R/print.R @@ -0,0 +1,14 @@ +#' Print a Simple Linear Regression Model Summary +#' +#' Prints a summary of a simple linear regression model. +#' +#' @param x An object of class "mylin". +#' @param ... Additional arguments. +#' @export +print.mylin <- function(x, ...) { + cat("\nCall:\n", deparse(x$call), "\n\n") + cat("Coefficients:\n") + print.default(format(x$coefficients), print.gap = 2L, quote = FALSE) + cat("\n") + invisible(x) +} \ No newline at end of file diff --git a/mypkgs/mylin2024111211/man/lin_reg.Rd b/mypkgs/mylin2024111211/man/lin_reg.Rd new file mode 100644 index 0000000..06afc0d --- /dev/null +++ b/mypkgs/mylin2024111211/man/lin_reg.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lin_reg.R +\name{lin_reg} +\alias{lin_reg} +\title{Linear Regression Model} +\usage{ +lin_reg( + formula, + data, + subset, + weights, + na.action, + method = "qr", + model = TRUE, + return_x = FALSE, + return_y = FALSE, + qr = TRUE, + singular.ok = TRUE, + contrasts = NULL, + offset +) +} +\arguments{ +\item{formula}{describle model formula, such as y ~ x} + +\item{data}{data build from data.frame, such as data.frame(x = x, y = y)} + +\item{subset}{none} + +\item{weights}{none} + +\item{na.action}{none} + +\item{method}{which method is used to fit linear model.} + +\item{model}{whether return a model class.} + +\item{return_x}{whether need to return designer matrix. default False} + +\item{return_y}{whether need to return response variable . default False} + +\item{qr}{none} + +\item{singular.ok}{none} + +\item{contrasts}{none} + +\item{offset}{none} +} +\value{ +return a list consist of coefficiences and formula +} +\description{ +train a linear model +} diff --git a/mypkgs/mylin2024111211/man/predict.Rd b/mypkgs/mylin2024111211/man/predict.Rd new file mode 100644 index 0000000..718ad82 --- /dev/null +++ b/mypkgs/mylin2024111211/man/predict.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/predict.R +\name{predict} +\alias{predict} +\title{Predict via Linear Regression Model} +\usage{ +predict(model, newdata) +} +\arguments{ +\item{model}{describle model formula} + +\item{newdata}{build from data.frame} +} +\value{ +return a list consist of coefficiences and formula +} +\description{ +train a linear model +} diff --git a/mypkgs/mylin2024111211/man/print.lm.Rd b/mypkgs/mylin2024111211/man/print.lm.Rd new file mode 100644 index 0000000..94e85f3 --- /dev/null +++ b/mypkgs/mylin2024111211/man/print.lm.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.R +\name{print.lm} +\alias{print.lm} +\title{Linear Regression Model} +\usage{ +\method{print}{lm}(model) +} +\arguments{ +\item{model}{the model you want to display} +} +\value{ +return a list consist of coefficiences and formula +} +\description{ +train a linear model +} diff --git a/mypkgs/mylin2024111211/man/save_model.Rd b/mypkgs/mylin2024111211/man/save_model.Rd new file mode 100644 index 0000000..61fb8bc --- /dev/null +++ b/mypkgs/mylin2024111211/man/save_model.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lin_reg.R +\name{save_model} +\alias{save_model} +\title{Linear Regression Model} +\usage{ +save_model(model, filename) +} +\arguments{ +\item{filename}{the save model file name} + +\item{mode}{the linear model you want to save} +} +\value{ +none +} +\description{ +save model +} diff --git a/mypkgs/mylin2024111211/mylin2024111211.Rproj b/mypkgs/mylin2024111211/mylin2024111211.Rproj new file mode 100644 index 0000000..aaa62a5 --- /dev/null +++ b/mypkgs/mylin2024111211/mylin2024111211.Rproj @@ -0,0 +1,17 @@ +Version: 1.0 + +RestoreWorkspace: No +SaveWorkspace: No +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +Encoding: UTF-8 + +AutoAppendNewline: Yes +StripTrailingWhitespace: Yes +LineEndingConversion: Posix + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source +PackageRoxygenize: rd,collate,namespace